From f85865a05aa3914a478a46e6f10a5ac442d793a2 Mon Sep 17 00:00:00 2001 From: Giacomo Leidi Date: Mon, 2 Jan 2023 18:44:51 +0100 Subject: home: services: fontutils: Add service value. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/home/services/fontutils.scm (add-fontconfig-config-file): Add support for multiple paths; (home-fontconfig-service-type): Honor it; * doc/guix.texi (Fonts Services): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 2b1ad77ba5..64873db00b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -41130,6 +41130,7 @@ services)}. * SSH: Secure Shell. Setting up the secure shell client. * Desktop: Desktop Home Services. Services for graphical environments. * Guix: Guix Home Services. Services for Guix. +* Fonts: Fonts Home Services. Services for managing User's fonts. @end menu @c In addition to that Home Services can provide @@ -42014,6 +42015,35 @@ A typical extension for adding a channel might look like this: @end lisp @end defvar +@node Fonts Home Services +@subsection Fonts Home Services + +The @code{(gnu home services fontutils)} module provides services for +user-specific Fontconfig setup. The +@uref{https://www.freedesktop.org/wiki/Software/fontconfig,Fontconfig} +library is used by many applications to access fonts on the system. + +@defvar home-fontconfig-service-type +This is the service type for generating configurations for Fontconfig. +Its associated value is a list of strings (or gexps) pointing to fonts +locations. + +Generally, it is better to extend this service than to directly +configure it, as its default value is the default Guix Home's profile +font installation path (@file{~/.guix-home/profile/share/fonts}). If +you configure this service directly, be sure to include the above +directory. + +A typical extension for adding an additional font directory might look +like this: + +@lisp +(simple-service 'additional-fonts-service + home-fontconfig-service-type + (list "~/.nix-profile/share/fonts")) +@end lisp +@end defvar + @node Invoking guix home @section Invoking @command{guix home} -- cgit 1.4.1 From 9a5533c653522a4fbba61c3ea17ff6fa0f96af9f Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 3 Feb 2023 15:18:44 +0100 Subject: services: nar-herder: Add cached compression support. * gnu/services/guix.scm (): New record type. (nar-herder-configuration-cached-compressions, nar-herder-configuration-cached-compression-min-uses, nar-herder-configuration-cached-compression-workers, nar-herder-configuration-cached-compression-nar-source, nar-herder-cached-compression-configuration, nar-herder-cached-compression-configuration?, nar-herder-cached-compression-configuration-type, nar-herder-cached-compression-configuration-level, nar-herder-cached-compression-configuration-directory, nar-herder-cached-compression-configuration-directory-max-size): New procedures. * doc/guix.texi (Guix Services): Document this. --- doc/guix.texi | 36 ++++++++++++++++++++++ gnu/services/guix.scm | 85 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 118 insertions(+), 3 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 64873db00b..d69be8586e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -36836,6 +36836,42 @@ advertised. Log level to use, specify a log level like @code{'INFO} to stop logging individual requests. +@item @code{cached-compressions} (default: @code{'()}) +Activate generating cached nars with different compression details from +the stored nars. This is a list of +nar-herder-cached-compression-configuration records. + +@item @code{min-uses} (default: @code{3}) +When cached-compressions are enabled, generate cached nars when at least +this number of requests are made for a nar. + +@item @code{workers} (default: @code{2}) +Number of cached nars to generate at a time. + +@item @code{nar-source} (default: @code{#f}) +Location to fetch nars from when computing cached compressions. By +default, the storage location will be used. + +@end table +@end deftp + +@deftp {Data Type} nar-herder-cached-compression-configuration +Data type representing the cached compression configuration. + +@table @asis +@item @code{type} +Type of compression to use, e.g. @code{'zstd}. + +@item @code{workers} (default: @code{#f}) +Level of the compression to use. + +@item @code{directory} (default: @code{#f}) +Location to store the cached nars. If unspecified, they will be stored +in /var/cache/nar-herder/nar/TYPE. + +@item @code{directory-max-size} (default: @code{#f}) +Maximum size in bytes of the directory. + @end table @end deftp diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm index 65bf0b5a7f..2dfedc553e 100644 --- a/gnu/services/guix.scm +++ b/gnu/services/guix.scm @@ -126,7 +126,18 @@ nar-herder-configuration-storage nar-herder-configuration-storage-limit nar-herder-configuration-storage-nar-removal-criteria - nar-herder-configuration-log-level)) + nar-herder-configuration-log-level + nar-herder-configuration-cached-compressions + nar-herder-configuration-cached-compression-min-uses + nar-herder-configuration-cached-compression-workers + nar-herder-configuration-cached-compression-nar-source + + nar-herder-cached-compression-configuration + nar-herder-cached-compression-configuration? + nar-herder-cached-compression-configuration-type + nar-herder-cached-compression-configuration-level + nar-herder-cached-compression-configuration-directory + nar-herder-cached-compression-configuration-directory-max-size)) ;;;; Commentary: ;;; @@ -828,17 +839,67 @@ ca-certificates.crt file in the system profile." (negative-ttl nar-herder-configuration-negative-ttl (default #f)) (log-level nar-herder-configuration-log-level - (default 'DEBUG))) + (default 'DEBUG)) + (cached-compressions + nar-herder-configuration-cached-compressions + (default '())) + (cached-compression-min-uses + nar-herder-configuration-cached-compression-min-uses + (default 3)) + (cached-compression-workers + nar-herder-configuration-cached-compression-workers + (default 2)) + (cached-compression-nar-source + nar-herder-configuration-cached-compression-nar-source + (default #f))) +(define-record-type* + nar-herder-cached-compression-configuration + make-nar-herder-cached-compression-configuration + nar-herder-cached-compression-configuration? + (type nar-herder-cached-compression-configuration-type) + (level nar-herder-cached-compression-configuration-level + (default #f)) + (directory nar-herder-cached-compression-configuration-directory + (default #f)) + (directory-max-size + nar-herder-cached-compression-configuration-directory-max-size + (default #f))) (define (nar-herder-shepherd-services config) + (define (cached-compression-configuration->options cached-compression) + (match-record + cached-compression + + (type level directory directory-max-size) + + `(,(simple-format #f "--enable-cached-compression=~A~A" + type + (if level + (simple-format #f ":~A" level) + "")) + ,@(if directory + (list + (simple-format #f "--cached-compression-directory=~A=~A" + type + directory)) + '()) + ,@(if directory-max-size + (list + (simple-format #f "--cached-compression-directory-max-size=~A=~A" + type + directory-max-size)) + '())))) + (match-record config (package user group mirror database database-dump host port storage storage-limit storage-nar-removal-criteria - ttl negative-ttl log-level) + ttl negative-ttl log-level + cached-compressions cached-compression-min-uses + cached-compression-workers cached-compression-nar-source) (unless (or mirror storage) (error "nar-herder: mirror or storage must be set")) @@ -882,6 +943,24 @@ ca-certificates.crt file in the system profile." '()) #$@(if log-level (list (simple-format #f "--log-level=~A" log-level)) + '()) + #$@(append-map + cached-compression-configuration->options + cached-compressions) + #$@(if cached-compression-min-uses + (list (simple-format + #f "--cached-compression-min-uses=~A" + cached-compression-min-uses)) + '()) + #$@(if cached-compression-workers + (list (simple-format + #f "--cached-compression-workers=~A" + cached-compression-workers)) + '()) + #$@(if cached-compression-nar-source + (list (simple-format + #f "--cached-compression-nar-source=~A" + cached-compression-nar-source)) '())) #:user #$user #:group #$group -- cgit 1.4.1 From 5c5f0fc1135ff15f9c4adfc5f27eadd9a592b5d1 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Thu, 2 Feb 2023 20:07:37 +0000 Subject: services: mpd: Refactor MPD service. Refactor mpd-service-type to support additional mpd.conf directives and move activation-service-extension into service constructor. * gnu/services/audio.scm (mpd-plugin, mpd-partition): New records. (mpd-serialize-boolean): Alias to and integrate logic into... (mpd-serialize-field): ... this. (mpd-serialize-list-of-string): New variable. (mpd-plugin?, mpd-partition?, list-of-string?, list-of-symbol?) (list-of-mpd-plugin?, list-of-mpd-partition?) (list-of-mpd-plugin-or-output?, port?): New variables. (mpd-file-name, mpd-service-activation): Remove variables. (mpd-configuration) [package, group, shepherd-requirement, log-file, log-level, music-directory] [playlist-directory, endpoints, database, partitions, neighbors, inputs] [archive-plugins, input-cache-size, decoders, resampler, filters] [playlist-plugins, extra-options]: New fields. [music-dir, playlist-dir, address]: Deprecate shorthand fields. [db-file, state-file, sticker-file, port, outputs]: Change admissible type. (mpd-shepherd-service) [actions]: New shepherd actions: 'reopen' and 'configuration'. [requirement]: Splice with 'shepherd-requirement' field. [start]: Use 'package' field. Remove #:log-file parameter. Move activation-service extension into constructor. (mpd-accounts): Honor user and group names from configuration. (mpd-log-rotation): New procedure. (mpd-service-type)[extensions]: Add rottlog-service-type extension. Remove activation-service-type extension. (mpd-output-name, mpd-output-type, mpd-output-enabled?, mpd-output-format) (mpd-output-tags?, mpd-output-always-on?, mpd-output-mixer-type) (mpd-output-replay-gain-handler, mpd-output-extra-options) (mpd-plugin-plugin, mpd-plugin-name, mpd-plugin-enabled?) (mpd-plugin-extra-options) (mpd-partition-name, mpd-partition-extra-options) (mpd-configuration-package, mpd-configuration-user) (mpd-configuration-group, mpd-configuration-shepherd-requirement) (mpd-configuration-log-file, mpd-configuration-log-level) (mpd-configuration-music-directory, mpd-configuration-music-dir) (mpd-configuration-playlist-directory, mpd-configuration-playlist-dir) (mpd-configuration-db-file, mpd-configuration-state-file) (mpd-configuration-sticker-file, mpd-configuration-default-port) (mpd-configuration-endpoints, mpd-configuration-address) (mpd-configuration-database, mpd-configuration-partitions) (mpd-configuration-neighbors, mpd-configuration-inputs) (mpd-configuration-archive-plugins, mpd-configuration-input-cache-size) (mpd-configuration-decoders, mpd-configuration-resampler) (mpd-configuration-filters, mpd-configuration-outputs) (mpd-configuration-playlist-plugins, mpd-configuration-extra-options): Export accessors. * doc/guix.texi (Audio Services)[Music Player Daemon]: Update documentation. Signed-off-by: Liliana Marie Prikler --- doc/guix.texi | 177 +++++++++++++++--- gnu/services/audio.scm | 493 +++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 543 insertions(+), 127 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index d69be8586e..cd18959db0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -109,6 +109,7 @@ Copyright @copyright{} 2022 Reily Siegel@* Copyright @copyright{} 2022 Simon Streit@* Copyright @copyright{} 2022 (@* Copyright @copyright{} 2022 John Kehayias@* +Copyright @copyright{} 2022 Bruno Victal@* Copyright @copyright{} 2022 Ivan Vilata-i-Balaguer@* Copyright @copyright{} 2023 Giacomo Leidi@* Copyright @copyright{} 2022 Antero Mejr@* @@ -33185,79 +33186,187 @@ The service type for @command{mpd} Data type representing the configuration of @command{mpd}. @table @asis -@item @code{user} (default: @code{"mpd"}) +@item @code{package} (default: @code{mpd}) (type: file-like) +The MPD package. + +@item @code{user} (default: @code{"mpd"}) (type: string) The user to run mpd as. -@item @code{music-dir} (default: @code{"~/Music"}) +@item @code{group} (default: @code{"mpd"}) (type: string) +The group to run mpd as. + +@item @code{shepherd-requirement} (default: @code{()}) (type: list-of-symbol) +This is a list of symbols naming Shepherd services that this service +will depend on. + +@item @code{log-file} (default: @code{"/var/log/mpd/log"}) (type: maybe-string) +The location of the log file. Set to @code{syslog} to use the local +syslog daemon or @code{%unset-value} to omit this directive from the +configuration file. + +@item @code{log-level} (type: maybe-string) +Supress any messages below this threshold. Available values: +@code{notice}, @code{info}, @code{verbose}, @code{warning} and +@code{error}. + +@item @code{music-directory} (type: maybe-string) The directory to scan for music files. -@item @code{playlist-dir} (default: @code{"~/.mpd/playlists"}) +@item @code{playlist-directory} (type: maybe-string) The directory to store playlists. -@item @code{db-file} (default: @code{"~/.mpd/tag_cache"}) +@item @code{db-file} (type: maybe-string) The location of the music database. -@item @code{state-file} (default: @code{"~/.mpd/state"}) +@item @code{state-file} (type: maybe-string) The location of the file that stores current MPD's state. -@item @code{sticker-file} (default: @code{"~/.mpd/sticker.sql"}) +@item @code{sticker-file} (type: maybe-string) The location of the sticker database. -@item @code{port} (default: @code{"6600"}) -The port to run mpd on. +@item @code{default-port} (default: @code{6600}) (type: maybe-integer) +The default port to run mpd on. + +@item @code{endpoints} (type: maybe-list-of-string) +The addresses that mpd will bind to. A port different from @var{default-port} +may be specified, e.g. @code{localhost:6602} and IPv6 addresses must be +enclosed in square brackets when a different port is used. +To use a Unix domain socket, an absolute path or a path starting with @code{~} +can be specified here. + +@item @code{database} (type: maybe-mpd-plugin) +MPD database plugin configuration. + +@item @code{partitions} (default: @code{()}) (type: list-of-mpd-partition) +List of MPD "partitions". -@item @code{address} (default: @code{"any"}) -The address that mpd will bind to. To use a Unix domain socket, -an absolute path can be specified here. +@item @code{neighbors} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD neighbor plugin configurations. -@item @code{outputs} (default: @code{"(list (mpd-output))"}) -The audio outputs that MPD can use. By default this is a single output using pulseaudio. +@item @code{inputs} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD input plugin configurations. + +@item @code{archive-plugins} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD archive plugin configurations. + +@item @code{input-cache-size} (type: maybe-string) +MPD input cache size. + +@item @code{decoders} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD decoder plugin configurations. + +@item @code{resampler} (type: maybe-mpd-plugin) +MPD resampler plugin configuration. + +@item @code{filters} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD filter plugin configurations. + +@item @code{outputs} (type: list-of-mpd-plugin-or-output) +The audio outputs that MPD can use. By default this is a single output +using pulseaudio. + +@item @code{playlist-plugins} (default: @code{()}) (type: list-of-mpd-plugin) +List of MPD playlist plugin configurations. + +@item @code{extra-options} (default: @code{()}) (type: alist) +An association list of option symbols/strings to string values to be +appended to the configuration. + +@end table +@end deftp + +@deftp {Data Type} mpd-plugin +Data type representing a @command{mpd} plugin. + +@table @asis +@item @code{plugin} (type: maybe-string) +Plugin name. + +@item @code{name} (type: maybe-string) +Name. + +@item @code{enabled?} (type: maybe-boolean) +Whether the plugin is enabled/disabled. + +@item @code{extra-options} (default: @code{()}) (type: alist) +An association list of option symbols/strings to string values to be +appended to the plugin configuration. See +@uref{https://mpd.readthedocs.io/en/latest/plugins.html,MPD plugin +reference} for available options. + +@end table +@end deftp + +@deftp {Data Type} mpd-partition +Data type representing a @command{mpd} partition. + +@table @asis +@item @code{name} (type: string) +Partition name. + +@item @code{extra-options} (default: @code{()}) (type: alist) +An association list of option symbols/strings to string values to be +appended to the partition configuration. See +@uref{https://mpd.readthedocs.io/en/latest/user.html#configuring-partitions,Configuring +Partitions} for available options. @end table @end deftp @deftp {Data Type} mpd-output -Data type representing an @command{mpd} audio output. +Data type representing a @command{mpd} audio output. @table @asis -@item @code{name} (default: @code{"MPD"}) +@item @code{name} (default: @code{"MPD"}) (type: string) The name of the audio output. -@item @code{type} (default: @code{"pulse"}) +@item @code{type} (default: @code{"pulse"}) (type: string) The type of audio output. -@item @code{enabled?} (default: @code{#t}) +@item @code{enabled?} (default: @code{#t}) (type: boolean) Specifies whether this audio output is enabled when MPD is started. By default, all audio outputs are enabled. This is just the default setting when there is no state file; with a state file, the previous state is restored. -@item @code{tags?} (default: @code{#t}) +@item @code{format} (type: maybe-string) +Force a specific audio format on output. See +@uref{https://mpd.readthedocs.io/en/latest/user.html#audio-output-format,Global +Audio Format} for a more detailed description. + +@item @code{tags?} (default: @code{#t}) (type: boolean) If set to @code{#f}, then MPD will not send tags to this output. This is only useful for output plugins that can receive tags, for example the @code{httpd} output plugin. -@item @code{always-on?} (default: @code{#f}) +@item @code{always-on?} (default: @code{#f}) (type: boolean) If set to @code{#t}, then MPD attempts to keep this audio output always -open. This may be useful for streaming servers, when you don’t want to +open. This may be useful for streaming servers, when you don?t want to disconnect all listeners even when playback is accidentally stopped. -@item @code{mixer-type} -This field accepts a symbol that specifies which mixer should be used +@item @code{mixer-type} (default: @code{"none"}) (type: string) +This field accepts a string that specifies which mixer should be used for this audio output: the @code{hardware} mixer, the @code{software} mixer, the @code{null} mixer (allows setting the volume, but with no effect; this can be used as a trick to implement an external mixer External Mixer) or no mixer (@code{none}). -@item @code{extra-options} (default: @code{'()}) -An association list of option symbols to string values to be appended to -the audio output configuration. +@item @code{replay-gain-handler} (type: maybe-string) +This field accepts a string that specifies how +@uref{https://mpd.readthedocs.io/en/latest/user.html#replay-gain,Replay +Gain} is to be applied. @code{software} uses an internal software +volume control, @code{mixer} uses the configured (hardware) mixer +control and @code{none} disables replay gain on this audio output. + +@item @code{extra-options} (default: @code{()}) (type: alist) +An association list of option symbols/strings to string values to be +appended to the audio output configuration. @end table @end deftp -The following example shows a configuration of @code{mpd} that provides -an HTTP audio streaming output. +The following example shows a configuration of @command{mpd} that +configures some of its plugins and provides a HTTP audio streaming output. @lisp (service mpd-service-type @@ -33269,7 +33378,19 @@ an HTTP audio streaming output. (mixer-type 'null) (extra-options `((encoder . "vorbis") - (port . "8080")))))))) + (port . "8080")))))) + (decoders + (list (mpd-plugin + (plugin "mikmod") + (enabled? #f)) + (mpd-plugin + (plugin "openmpt") + (enabled? #t) + (extra-options `((repeat-count . -1) + (interpolation-filter . 1)))))) + (resampler (mpd-plugin + (plugin "libsamplerate") + (extra-options `((type . 0))))))) @end lisp diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm index b7cb0ebe38..2bb8f66c96 100644 --- a/gnu/services/audio.scm +++ b/gnu/services/audio.scm @@ -21,9 +21,13 @@ (define-module (gnu services audio) #:use-module (guix gexp) + #:use-module (guix deprecation) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (gnu services) #:use-module (gnu services configuration) #:use-module (gnu services shepherd) + #:use-module (gnu services admin) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages mpd) @@ -31,10 +35,61 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (mpd-output mpd-output? + mpd-output-name + mpd-output-type + mpd-output-enabled? + mpd-output-format + mpd-output-tags? + mpd-output-always-on? + mpd-output-mixer-type + mpd-output-replay-gain-handler + mpd-output-extra-options + + mpd-plugin + mpd-plugin? + mpd-plugin-plugin + mpd-plugin-name + mpd-plugin-enabled? + mpd-plugin-extra-options + + mpd-partition + mpd-partition? + mpd-partition-name + mpd-partition-extra-options + mpd-configuration mpd-configuration? + mpd-configuration-package + mpd-configuration-user + mpd-configuration-group + mpd-configuration-shepherd-requirement + mpd-configuration-log-file + mpd-configuration-log-level + mpd-configuration-music-directory + mpd-configuration-music-dir + mpd-configuration-playlist-directory + mpd-configuration-playlist-dir + mpd-configuration-db-file + mpd-configuration-state-file + mpd-configuration-sticker-file + mpd-configuration-default-port + mpd-configuration-endpoints + mpd-configuration-address + mpd-configuration-database + mpd-configuration-partitions + mpd-configuration-neighbors + mpd-configuration-inputs + mpd-configuration-archive-plugins + mpd-configuration-input-cache-size + mpd-configuration-decoders + mpd-configuration-resampler + mpd-configuration-filters + mpd-configuration-outputs + mpd-configuration-playlist-plugins + mpd-configuration-extra-options mpd-service-type)) ;;; Commentary: @@ -50,34 +105,125 @@ str) #\-) "_"))) +(define list-of-string? + (list-of string?)) + +(define list-of-symbol? + (list-of symbol?)) + (define (mpd-serialize-field field-name value) - #~(format #f "~a ~s~%" #$(if (string? field-name) - field-name - (uglify-field-name field-name)) - #$(if (string? value) - value - (object->string value)))) + (let ((field (if (string? field-name) field-name + (uglify-field-name field-name))) + (value (cond + ((boolean? value) (if value "yes" "no")) + ((string? value) value) + (else (object->string value))))) + #~(format #f "~a ~s~%" #$field #$value))) (define (mpd-serialize-alist field-name value) #~(string-append #$@(generic-serialize-alist list mpd-serialize-field value))) (define mpd-serialize-string mpd-serialize-field) +(define mpd-serialize-boolean mpd-serialize-field) -(define (mpd-serialize-boolean field-name value) - (mpd-serialize-field field-name (if value "yes" "no"))) +(define (mpd-serialize-list-of-string field-name value) + #~(string-concatenate #$(map (cut mpd-serialize-string field-name <>) value))) -(define (mpd-serialize-list-of-mpd-output field-name value) - #~(string-append "\naudio_output {\n" - #$@(map (cut serialize-configuration <> - mpd-output-fields) - value) - "}\n")) +(define-maybe string (prefix mpd-)) +(define-maybe list-of-string (prefix mpd-)) +(define-maybe boolean (prefix mpd-)) -(define (mpd-serialize-configuration configuration) - (mixed-text-file - "mpd.conf" - (serialize-configuration configuration mpd-configuration-fields))) +;;; TODO: Procedures for deprecated fields, to be removed. + +(define mpd-deprecated-fields '((music-dir . music-directory) + (playlist-dir . playlist-directory) + (address . endpoints))) + +(define (port? value) (or (string? value) (integer? value))) + +(define (mpd-serialize-deprecated-field field-name value) + (if (maybe-value-set? value) + (begin + (warn-about-deprecation + field-name #f + #:replacement (assoc-ref mpd-deprecated-fields field-name)) + (match field-name + ('playlist-dir (mpd-serialize-string "playlist_directory" value)) + ('music-dir (mpd-serialize-string "music_directory" value)) + ('address (mpd-serialize-string "bind_to_address" value)))) + "")) + +(define (mpd-serialize-port field-name value) + (when (string? value) + (warning + (G_ "string value for '~a' is deprecated, use integer instead~%") + field-name)) + (mpd-serialize-field "port" value)) + +(define-maybe port (prefix mpd-)) + +;;; + +;; Generic MPD plugin record, lists only the most prevalent fields. +(define-configuration mpd-plugin + (plugin + maybe-string + "Plugin name.") + + (name + maybe-string + "Name.") + + (enabled? + maybe-boolean + "Whether the plugin is enabled/disabled.") + + (extra-options + (alist '()) + "An association list of option symbols/strings to string values +to be appended to the plugin configuration. See +@uref{https://mpd.readthedocs.io/en/latest/plugins.html,MPD plugin reference} +for available options.") + + (prefix mpd-)) + +(define (mpd-serialize-mpd-plugin field-name value) + #~(format #f "~a {~%~a}~%" + '#$field-name + #$(serialize-configuration value mpd-plugin-fields))) + +(define (mpd-serialize-list-of-mpd-plugin field-name value) + #~(string-append #$@(map (cut mpd-serialize-mpd-plugin field-name <>) + value))) + +(define list-of-mpd-plugin? (list-of mpd-plugin?)) + +(define-maybe mpd-plugin (prefix mpd-)) + +(define-configuration mpd-partition + (name + string + "Partition name.") + + (extra-options + (alist '()) + "An association list of option symbols/strings to string values +to be appended to the partition configuration. See +@uref{https://mpd.readthedocs.io/en/latest/user.html#configuring-partitions,Configuring Partitions} +for available options.") + + (prefix mpd-)) + +(define (mpd-serialize-mpd-partition field-name value) + #~(format #f "partition {~%~a}~%" + #$(serialize-configuration value mpd-partition-fields))) + +(define (mpd-serialize-list-of-mpd-partition field-name value) + #~(string-append #$@(map (cut mpd-serialize-mpd-partition #f <>) value))) + +(define list-of-mpd-partition? + (list-of mpd-partition?)) (define-configuration mpd-output (name @@ -95,6 +241,12 @@ default, all audio outputs are enabled. This is just the default setting when there is no state file; with a state file, the previous state is restored.") + (format + maybe-string + "Force a specific audio format on output. See +@uref{https://mpd.readthedocs.io/en/latest/user.html#audio-output-format,Global Audio Format} +for a more detailed description.") + (tags? (boolean #t) "If set to @code{#f}, then MPD will not send tags to this output. This @@ -109,125 +261,268 @@ disconnect all listeners even when playback is accidentally stopped.") (mixer-type (string "none") - "This field accepts a symbol that specifies which mixer should be used + "This field accepts a string that specifies which mixer should be used for this audio output: the @code{hardware} mixer, the @code{software} mixer, the @code{null} mixer (allows setting the volume, but with no effect; this can be used as a trick to implement an external mixer External Mixer) or no mixer (@code{none}).") + (replay-gain-handler + maybe-string + "This field accepts a string that specifies how +@uref{https://mpd.readthedocs.io/en/latest/user.html#replay-gain,Replay Gain} +is to be applied. @code{software} uses an internal software volume control, +@code{mixer} uses the configured (hardware) mixer control and @code{none} +disables replay gain on this audio output.") + (extra-options (alist '()) - "An association list of option symbols to string values to be appended to -the audio output configuration.") + "An association list of option symbols/strings to string values +to be appended to the audio output configuration.") (prefix mpd-)) -(define list-of-mpd-output? - (list-of mpd-output?)) +(define (mpd-serialize-mpd-output field-name value) + #~(format #f "audio_output {~%~a}~%" + #$(serialize-configuration value mpd-output-fields))) + +(define (mpd-serialize-list-of-mpd-plugin-or-output field-name value) + (let ((plugins outputs (partition mpd-plugin? value))) + #~(string-append #$@(map (cut mpd-serialize-mpd-plugin "audio_output" <>) + plugins) + #$@(map (cut mpd-serialize-mpd-output #f <>) outputs)))) + +(define list-of-mpd-plugin-or-output? + (list-of (lambda (x) + (or (mpd-output? x) (mpd-plugin? x))))) (define-configuration mpd-configuration + (package + (file-like mpd) + "The MPD package." + empty-serializer) + (user (string "mpd") "The user to run mpd as.") - (music-dir - (string "~/Music") + (group + (string "mpd") + "The group to run mpd as.") + + (shepherd-requirement + (list-of-symbol '()) + "This is a list of symbols naming Shepherd services that this service +will depend on." + empty-serializer) + + (log-file + (maybe-string "/var/log/mpd/log") + "The location of the log file. Set to @code{syslog} to use the +local syslog daemon or @code{%unset-value} to omit this directive +from the configuration file.") + + (log-level + maybe-string + "Supress any messages below this threshold. +Available values: @code{notice}, @code{info}, @code{verbose}, +@code{warning} and @code{error}.") + + (music-directory + maybe-string + "The directory to scan for music files.") + + (music-dir ; TODO: deprecated, remove later + maybe-string "The directory to scan for music files." - (lambda (_ x) - (mpd-serialize-field "music_directory" x))) + mpd-serialize-deprecated-field) + + (playlist-directory + maybe-string + "The directory to store playlists.") - (playlist-dir - (string "~/.mpd/playlists") + (playlist-dir ; TODO: deprecated, remove later + maybe-string "The directory to store playlists." - (lambda (_ x) - (mpd-serialize-field "playlist_directory" x))) + mpd-serialize-deprecated-field) (db-file - (string "~/.mpd/tag_cache") + maybe-string "The location of the music database.") (state-file - (string "~/.mpd/state") + maybe-string "The location of the file that stores current MPD's state.") (sticker-file - (string "~/.mpd/sticker.sql") + maybe-string "The location of the sticker database.") - (port - (string "6600") - "The port to run mpd on.") - - (address - (string "any") + (default-port + (maybe-port 6600) + "The default port to run mpd on.") + + (endpoints + maybe-list-of-string + "The addresses that mpd will bind to. A port different from +@var{default-port} may be specified, e.g. @code{localhost:6602} and +IPv6 addresses must be enclosed in square brackets when a different +port is used. +To use a Unix domain socket, an absolute path or a path starting with @code{~} +can be specified here." + (lambda (_ endpoints) + (if (maybe-value-set? endpoints) + (mpd-serialize-list-of-string "bind_to_address" endpoints) + ""))) + + (address ; TODO: deprecated, remove later + maybe-string "The address that mpd will bind to. To use a Unix domain socket, an absolute path can be specified here." + mpd-serialize-deprecated-field) + + (database + maybe-mpd-plugin + "MPD database plugin configuration.") + + (partitions + (list-of-mpd-partition '()) + "List of MPD \"partitions\".") + + (neighbors + (list-of-mpd-plugin '()) + "List of MPD neighbor plugin configurations.") + + (inputs + (list-of-mpd-plugin '()) + "List of MPD input plugin configurations." (lambda (_ x) - (mpd-serialize-field "bind_to_address" x))) + (mpd-serialize-list-of-mpd-plugin "input" x))) + + (archive-plugins + (list-of-mpd-plugin '()) + "List of MPD archive plugin configurations." + (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "archive_plugin" x))) + + (input-cache-size + maybe-string + "MPD input cache size." + (lambda (_ x) + (if (maybe-value-set? x) + #~(string-append "\ninput_cache {\n" + #$(mpd-serialize-string "size" x) + "}\n") ""))) + + (decoders + (list-of-mpd-plugin '()) + "List of MPD decoder plugin configurations." + (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "decoder" x))) + + (resampler + maybe-mpd-plugin + "MPD resampler plugin configuration.") + + (filters + (list-of-mpd-plugin '()) + "List of MPD filter plugin configurations." + (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "filter" x))) (outputs - (list-of-mpd-output (list (mpd-output))) + (list-of-mpd-plugin-or-output (list (mpd-output))) "The audio outputs that MPD can use. By default this is a single output using pulseaudio.") + (playlist-plugins + (list-of-mpd-plugin '()) + "List of MPD playlist plugin configurations." + (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "playlist_plugin" x))) + + (extra-options + (alist '()) + "An association list of option symbols/strings to string values to be +appended to the configuration.") + (prefix mpd-)) -(define (mpd-file-name config file) - "Return a path in /var/run/mpd/ that is writable - by @code{user} from @code{config}." - (string-append "/var/run/mpd/" - (mpd-configuration-user config) - "/" file)) +(define (mpd-serialize-configuration configuration) + (mixed-text-file + "mpd.conf" + (serialize-configuration configuration mpd-configuration-fields))) + +(define (mpd-log-rotation config) + (match-record config (log-file) + (log-rotation + (files (list log-file)) + (post-rotate #~(begin + (use-modules (gnu services herd)) + (with-shepherd-action 'mpd ('reopen) #f)))))) (define (mpd-shepherd-service config) - (shepherd-service - (documentation "Run the MPD (Music Player Daemon)") - (requirement '(user-processes)) - (provision '(mpd)) - (start #~(make-forkexec-constructor - (list #$(file-append mpd "/bin/mpd") - "--no-daemon" - #$(mpd-serialize-configuration config)) - #:environment-variables - ;; Required to detect PulseAudio when run under a user account. - (list (string-append - "XDG_RUNTIME_DIR=/run/user/" - (number->string - (passwd:uid - (getpwnam #$(mpd-configuration-user config)))))) - #:log-file #$(mpd-file-name config "log"))) - (stop #~(make-kill-destructor)))) - -(define (mpd-service-activation config) - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (define %user - (getpw #$(mpd-configuration-user config))) - - (let ((directory #$(mpd-file-name config ".mpd"))) - (mkdir-p directory) - (chown directory (passwd:uid %user) (passwd:gid %user)) - - ;; Make /var/run/mpd/USER user-owned as well. - (chown (dirname directory) - (passwd:uid %user) (passwd:gid %user)))))) - - -(define %mpd-accounts - ;; Default account and group for MPD. - (list (user-group (name "mpd") (system? #t)) - (user-account - (name "mpd") - (group "mpd") - (system? #t) - (comment "Music Player Daemon (MPD) user") - - ;; Note: /var/run/mpd hosts one sub-directory per user, of which - ;; /var/run/mpd/mpd corresponds to the "mpd" user. - (home-directory "/var/run/mpd/mpd") - - (shell (file-append shadow "/sbin/nologin"))))) + (match-record config (user package shepherd-requirement + log-file playlist-directory + db-file state-file sticker-file) + (let* ((config-file (mpd-serialize-configuration config))) + (shepherd-service + (documentation "Run the MPD (Music Player Daemon)") + (requirement `(user-processes loopback ,@shepherd-requirement)) + (provision '(mpd)) + (start #~(begin + (and=> #$(maybe-value log-file) + (compose mkdir-p dirname)) + + (let ((user (getpw #$user))) + (for-each + (lambda (x) + (when (and x (not (file-exists? x))) + (mkdir-p x) + (chown x (passwd:uid user) (passwd:gid user)))) + (list #$(maybe-value playlist-directory) + (and=> #$(maybe-value db-file) dirname) + (and=> #$(maybe-value state-file) dirname) + (and=> #$(maybe-value sticker-file) dirname)))) + + (make-forkexec-constructor + (list #$(file-append package "/bin/mpd") + "--no-daemon" + #$config-file) + #:environment-variables + ;; Required to detect PulseAudio when run under a user account. + (list (string-append + "XDG_RUNTIME_DIR=/run/user/" + (number->string (passwd:uid (getpwnam #$user)))))))) + (stop #~(make-kill-destructor)) + (actions + (list (shepherd-configuration-action config-file) + (shepherd-action + (name 'reopen) + (documentation "Re-open log files and flush caches.") + (procedure + #~(lambda (pid) + (if pid + (begin + (kill pid SIGHUP) + (format #t + "Issued SIGHUP to Service MPD (PID ~a)." + pid)) + (format #t "Service MPD is not running."))))))))))) + +(define (mpd-accounts config) + (match-record config (user group) + (list (user-group + (name group) + (system? #t)) + (user-account + (name user) + (group group) + (system? #t) + (comment "Music Player Daemon (MPD) user") + ;; MPD can use $HOME (or $XDG_CONFIG_HOME) to place its data + (home-directory "/var/lib/mpd") + (shell (file-append shadow "/sbin/nologin")))))) (define mpd-service-type (service-type @@ -237,7 +532,7 @@ By default this is a single output using pulseaudio.") (list (service-extension shepherd-root-service-type (compose list mpd-shepherd-service)) (service-extension account-service-type - (const %mpd-accounts)) - (service-extension activation-service-type - mpd-service-activation))) + mpd-accounts) + (service-extension rottlog-service-type + (compose list mpd-log-rotation)))) (default-value (mpd-configuration)))) -- cgit 1.4.1 From 637a9c3b264fe8eb76b6ed9f104b635d95632be6 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Thu, 2 Feb 2023 20:07:38 +0000 Subject: services: mpd: Do not hardcode environment variables. Services should not expect for XDG_RUNTIME_DIR to be set. Inferring from the past comment, this seemed to resolve an issue when the service was launched with an _interactive_ user-account, which tends to have this variable set by the login-manager. This is not the case for system accounts and setting this variable results in PulseAudio (launched by the same system user) failing to start since it attempts to use a nonexistent directory. Ideally, this service should have a home-service counterpart but the old behavior can be emulated by setting the environment-variables field to: (environment-variables (list (string-append "XDG_RUNTIME_DIR=/run/user/" (number->string (passwd:uid (getpwnam "myuser")))))) * gnu/services/audio.scm (mpd-configuration)[environment-variables]: New field. (mpd-shepherd-service)[start]: Use new field. * doc/guix.texi (Audio Services)[Music Player Daemon]: Document it. Signed-off-by: Liliana Marie Prikler --- doc/guix.texi | 3 +++ gnu/services/audio.scm | 14 ++++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index cd18959db0..e7d56f2504 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -33199,6 +33199,9 @@ The group to run mpd as. This is a list of symbols naming Shepherd services that this service will depend on. +@item @code{environment-variables} (default: @code{()}) (type: list-of-string) +A list of strings specifying environment variables. + @item @code{log-file} (default: @code{"/var/log/mpd/log"}) (type: maybe-string) The location of the log file. Set to @code{syslog} to use the local syslog daemon or @code{%unset-value} to omit this directive from the diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm index 2bb8f66c96..3cbe21f23e 100644 --- a/gnu/services/audio.scm +++ b/gnu/services/audio.scm @@ -316,6 +316,11 @@ to be appended to the audio output configuration.") will depend on." empty-serializer) + (environment-variables + (list-of-string '()) + "A list of strings specifying environment variables." + empty-serializer) + (log-file (maybe-string "/var/log/mpd/log") "The location of the log file. Set to @code{syslog} to use the @@ -464,7 +469,8 @@ appended to the configuration.") (define (mpd-shepherd-service config) (match-record config (user package shepherd-requirement log-file playlist-directory - db-file state-file sticker-file) + db-file state-file sticker-file + environment-variables) (let* ((config-file (mpd-serialize-configuration config))) (shepherd-service (documentation "Run the MPD (Music Player Daemon)") @@ -489,11 +495,7 @@ appended to the configuration.") (list #$(file-append package "/bin/mpd") "--no-daemon" #$config-file) - #:environment-variables - ;; Required to detect PulseAudio when run under a user account. - (list (string-append - "XDG_RUNTIME_DIR=/run/user/" - (number->string (passwd:uid (getpwnam #$user)))))))) + #:environment-variables '#$environment-variables))) (stop #~(make-kill-destructor)) (actions (list (shepherd-configuration-action config-file) -- cgit 1.4.1 From 139c9a53cb19a97947aa6998eae953a4f32d3c3e Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Sat, 4 Feb 2023 20:28:16 +0000 Subject: services: Add mympd-service-type. * gnu/services/audio.scm (mympd-service-type): New variable. * gnu/tests/audio.scm (%test-mympd): New variable. * doc/guix.texi: Document it. Signed-off-by: Liliana Marie Prikler --- doc/guix.texi | 120 ++++++++++++++++++++++ gnu/services/audio.scm | 269 ++++++++++++++++++++++++++++++++++++++++++++++++- gnu/tests/audio.scm | 53 +++++++++- 3 files changed, 440 insertions(+), 2 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index e7d56f2504..359c9b7a47 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -113,6 +113,7 @@ Copyright @copyright{} 2022 Bruno Victal@* Copyright @copyright{} 2022 Ivan Vilata-i-Balaguer@* Copyright @copyright{} 2023 Giacomo Leidi@* Copyright @copyright{} 2022 Antero Mejr@* +Copyright @copyright{} 2022 Bruno Victal@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -33396,6 +33397,125 @@ configures some of its plugins and provides a HTTP audio streaming output. (extra-options `((type . 0))))))) @end lisp +@subsubheading myMPD + +@cindex MPD, web interface +@cindex myMPD service + +@uref{https://jcorporation.github.io/myMPD/, myMPD} is a web server +frontend for MPD that provides a mobile friendly web client for MPD. + +The following example shows a myMPD instance listening on port 80, +with album cover caching disabled. + +@lisp +(service mympd-service-type + (mympd-configuration + (port 80) + (covercache-ttl 0))) +@end lisp + +@defvar mympd-service-type +The service type for @command{mympd}. +@end defvar + +@c %start of fragment +@deftp {Data Type} mympd-configuration +Available @code{mympd-configuration} fields are: + +@table @asis +@item @code{package} (default: @code{mympd}) (type: file-like) +The package object of the myMPD server. + +@item @code{shepherd-requirement} (default: @code{()}) (type: list-of-symbol) +This is a list of symbols naming Shepherd services that this service +will depend on. + +@item @code{user} (default: @code{"mympd"}) (type: string) +Owner of the @command{mympd} process. + +@item @code{group} (default: @code{"nogroup"}) (type: string) +Owner group of the @command{mympd} process. + +@item @code{work-directory} (default: @code{"/var/lib/mympd"}) (type: string) +Where myMPD will store its data. + +@item @code{cache-directory} (default: @code{"/var/cache/mympd"}) (type: string) +Where myMPD will store its cache. + +@item @code{acl} (type: maybe-mympd-ip-acl) +ACL to access the myMPD webserver. + +@item @code{covercache-ttl} (default: @code{31}) (type: maybe-integer) +How long to keep cached covers, @code{0} disables cover caching. + +@item @code{http?} (default: @code{#t}) (type: boolean) +HTTP support. + +@item @code{host} (default: @code{"[::]"}) (type: string) +Host name to listen on. + +@item @code{port} (default: @code{80}) (type: maybe-port) +HTTP port to listen on. + +@item @code{log-level} (default: @code{5}) (type: integer) +How much detail to include in logs, possible values: @code{0} to +@code{7}. + +@item @code{log-to} (default: @code{"/var/log/mympd/log"}) (type: string-or-symbol) +Where to send logs. By default, the service logs to +@file{/var/log/mympd.log}. The alternative is @code{'syslog}, which +sends output to the running syslog service under the @samp{daemon} +facility. + +@item @code{lualibs} (default: @code{"all"}) (type: maybe-string) +See +@uref{https://jcorporation.github.io/myMPD/scripting/#lua-standard-libraries}. + +@item @code{uri} (type: maybe-string) +Override URI to myMPD. See +@uref{https://github.com/jcorporation/myMPD/issues/950}. + +@item @code{script-acl} (default: @code{(mympd-ip-acl (allow '("127.0.0.1")))}) (type: maybe-mympd-ip-acl) +ACL to access the myMPD script backend. + +@item @code{ssl?} (default: @code{#f}) (type: boolean) +SSL/TLS support. + +@item @code{ssl-port} (default: @code{443}) (type: maybe-port) +Port to listen for HTTPS. + +@item @code{ssl-cert} (type: maybe-string) +Path to PEM encoded X.509 SSL/TLS certificate (public key). + +@item @code{ssl-key} (type: maybe-string) +Path to PEM encoded SSL/TLS private key. + +@item @code{pin-hash} (type: maybe-string) +SHA-256 hashed pin used by myMPD to control settings access by prompting +a pin from the user. + +@item @code{save-caches?} (type: maybe-boolean) +Whether to preserve caches between service restarts. + +@end table +@end deftp +@c %end of fragment + +@c %start of fragment +@deftp {Data Type} mympd-ip-acl +Available @code{mympd-ip-acl} fields are: + +@table @asis +@item @code{allow} (default: @code{()}) (type: list-of-string) +Allowed IP addresses. + +@item @code{deny} (default: @code{()}) (type: list-of-string) +Disallowed IP addresses. + +@end table +@end deftp +@c %end of fragment @node Virtualization Services @subsection Virtualization Services diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm index 3cbe21f23e..630110db2a 100644 --- a/gnu/services/audio.scm +++ b/gnu/services/audio.scm @@ -25,6 +25,7 @@ #:use-module (guix diagnostics) #:use-module (guix i18n) #:use-module (gnu services) + #:use-module (gnu services admin) #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu services admin) @@ -32,6 +33,7 @@ #:use-module (gnu packages admin) #:use-module (gnu packages mpd) #:use-module (guix records) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -90,7 +92,37 @@ mpd-configuration-outputs mpd-configuration-playlist-plugins mpd-configuration-extra-options - mpd-service-type)) + mpd-service-type + + mympd-service-type + mympd-configuration + mympd-configuration? + mympd-configuration-package + mympd-configuration-shepherd-requirement + mympd-configuration-user + mympd-configuration-group + mympd-configuration-work-directory + mympd-configuration-cache-directory + mympd-configuration-acl + mympd-configuration-covercache-ttl + mympd-configuration-http? + mympd-configuration-host + mympd-configuration-port + mympd-configuration-log-level + mympd-configuration-log-to + mympd-configuration-lualibs + mympd-configuration-uri + mympd-configuration-script-acl + mympd-configuration-ssl? + mympd-configuration-ssl-port + mympd-configuration-ssl-cert + mympd-configuration-ssl-key + mympd-configuration-pin-hash + mympd-configuration-save-caches? + mympd-ip-acl + mympd-ip-acl? + mympd-ip-acl-allow + mympd-ip-acl-deny)) ;;; Commentary: ;;; @@ -538,3 +570,238 @@ appended to the configuration.") (service-extension rottlog-service-type (compose list mpd-log-rotation)))) (default-value (mpd-configuration)))) + + +;;; +;;; myMPD +;;; + +(define (string-or-symbol? x) + (or (symbol? x) (string? x))) + +(define-configuration/no-serialization mympd-ip-acl + (allow + (list-of-string '()) + "Allowed IP addresses.") + + (deny + (list-of-string '()) + "Disallowed IP addresses.")) + +(define-maybe/no-serialization integer) +(define-maybe/no-serialization mympd-ip-acl) + +;; XXX: The serialization procedures are insufficient since we require +;; access to multiple fields at once. +;; Fields marked with empty-serializer are never serialized and are +;; used for command-line arguments or by the service definition. +(define-configuration/no-serialization mympd-configuration + (package + (file-like mympd) + "The package object of the myMPD server." + empty-serializer) + + (shepherd-requirement + (list-of-symbol '()) + "This is a list of symbols naming Shepherd services that this service +will depend on." + empty-serializer) + + (user + (string "mympd") + "Owner of the @command{mympd} process." + empty-serializer) + + (group + (string "nogroup") + "Owner group of the @command{mympd} process." + empty-serializer) + + (work-directory + (string "/var/lib/mympd") + "Where myMPD will store its data." + empty-serializer) + + (cache-directory + (string "/var/cache/mympd") + "Where myMPD will store its cache." + empty-serializer) + + (acl + maybe-mympd-ip-acl + "ACL to access the myMPD webserver.") + + (covercache-ttl + (maybe-integer 31) + "How long to keep cached covers, @code{0} disables cover caching.") + + (http? + (boolean #t) + "HTTP support.") + + (host + (string "[::]") + "Host name to listen on.") + + (port + (maybe-port 80) + "HTTP port to listen on.") + + (log-level + (integer 5) + "How much detail to include in logs, possible values: @code{0} to @code{7}.") + + (log-to + (string-or-symbol "/var/log/mympd/log") + "Where to send logs. By default, the service logs to +@file{/var/log/mympd.log}. The alternative is @code{'syslog}, which +sends output to the running syslog service under the @samp{daemon} facility." + empty-serializer) + + (lualibs + (maybe-string "all") + "See +@url{https://jcorporation.github.io/myMPD/scripting/#lua-standard-libraries}.") + + (uri + maybe-string + "Override URI to myMPD. +See @url{https://github.com/jcorporation/myMPD/issues/950}.") + + (script-acl + (maybe-mympd-ip-acl (mympd-ip-acl + (allow '("127.0.0.1")))) + "ACL to access the myMPD script backend.") + + (ssl? + (boolean #f) + "SSL/TLS support.") + + (ssl-port + (maybe-port 443) + "Port to listen for HTTPS.") + + (ssl-cert + maybe-string + "Path to PEM encoded X.509 SSL/TLS certificate (public key).") + + (ssl-key + maybe-string + "Path to PEM encoded SSL/TLS private key.") + + (pin-hash + maybe-string + "SHA-256 hashed pin used by myMPD to control settings access by +prompting a pin from the user.") + + (save-caches? + maybe-boolean + "Whether to preserve caches between service restarts.")) + +(define (mympd-serialize-configuration config) + (define serialize-value + (match-lambda + ((? boolean? val) (if val "true" "false")) + ((? integer? val) (number->string val)) + ((? mympd-ip-acl? val) (ip-acl-serialize-configuration val)) + ((? string? val) val))) + + (define (ip-acl-serialize-configuration config) + (define (serialize-list-of-string prefix lst) + (map (cut format #f "~a~a" prefix <>) lst)) + (string-join + (append + (serialize-list-of-string "+" (mympd-ip-acl-allow config)) + (serialize-list-of-string "-" (mympd-ip-acl-deny config))) ",")) + + ;; myMPD configuration fields are serialized as individual files under + ;; /config/. + (match-record config (work-directory acl + covercache-ttl http? host port + log-level lualibs uri script-acl + ssl? ssl-port ssl-cert ssl-key + pin-hash save-caches?) + (define (serialize-field filename value) + (when (maybe-value-set? value) + (list (format #f "~a/config/~a" work-directory filename) + (mixed-text-file filename (serialize-value value))))) + + (let ((filename-to-field `(("acl" . ,acl) + ("covercache_keep_days" . ,covercache-ttl) + ("http" . ,http?) + ("http_host" . ,host) + ("http_port" . ,port) + ("loglevel" . ,log-level) + ("lualibs" . ,lualibs) + ("mympd_uri" . ,uri) + ("scriptacl" . ,script-acl) + ("ssl" . ,ssl?) + ("ssl_port" . ,ssl-port) + ("ssl_cert" . ,ssl-cert) + ("ssl_key" . ,ssl-key) + ("pin_hash" . ,pin-hash) + ("save_caches" . ,save-caches?)))) + (filter list? + (generic-serialize-alist list serialize-field + filename-to-field))))) + +(define (mympd-shepherd-service config) + (match-record config (package shepherd-requirement + user work-directory + cache-directory log-level log-to) + (let ((log-level* (format #f "MYMPD_LOGLEVEL=~a" log-level))) + (shepherd-service + (documentation "Run the myMPD daemon.") + (requirement `(loopback user-processes ,@shepherd-requirement)) + (provision '(mympd)) + (start #~(begin + (let* ((pw (getpwnam #$user)) + (uid (passwd:uid pw)) + (gid (passwd:gid pw))) + (for-each (lambda (dir) + (mkdir-p dir) + (chown dir uid gid)) + (list #$work-directory #$cache-directory))) + + (make-forkexec-constructor + `(#$(file-append package "/bin/mympd") + "--user" #$user + #$@(if (eqv? log-to 'syslog) '("--syslog") '()) + "--workdir" #$work-directory + "--cachedir" #$cache-directory) + #:environment-variables (list #$log-level*) + #:log-file #$(if (string? log-to) log-to #f)))) + (stop #~(make-kill-destructor)))))) + +(define (mympd-accounts config) + (match-record config (user group) + (list (user-group (name group) + (system? #t)) + (user-account (name user) + (group group) + (system? #t) + (comment "myMPD user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")))))) + +(define (mympd-log-rotation config) + (match-record config (log-to) + (if (string? log-to) + (list (log-rotation + (files (list log-to)))) + '()))) + +(define mympd-service-type + (service-type + (name 'mympd) + (extensions + (list (service-extension shepherd-root-service-type + (compose list mympd-shepherd-service)) + (service-extension account-service-type + mympd-accounts) + (service-extension special-files-service-type + mympd-serialize-configuration) + (service-extension rottlog-service-type + mympd-log-rotation))) + (description "Run myMPD, a frontend for MPD. (Music Player Daemon)") + (default-value (mympd-configuration)))) diff --git a/gnu/tests/audio.scm b/gnu/tests/audio.scm index 8aa6d1e818..acb91293e8 100644 --- a/gnu/tests/audio.scm +++ b/gnu/tests/audio.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen +;;; Copyright © 2022 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,9 +23,11 @@ #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services audio) + #:use-module (gnu services networking) #:use-module (gnu packages mpd) #:use-module (guix gexp) - #:export (%test-mpd)) + #:export (%test-mpd + %test-mympd)) (define %mpd-os (simple-operating-system @@ -76,3 +79,51 @@ (name "mpd") (description "Test that the mpd can run and be connected to.") (value (run-mpd-test)))) + +(define (run-mympd-test) + (define os (marionette-operating-system + (simple-operating-system (service dhcp-client-service-type) + (service mympd-service-type)) + #:imported-modules '((gnu services herd)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((8080 . 80))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-64) + (srfi srfi-8) + (web client) + (web response) + (gnu build marionette)) + + (define marionette + (make-marionette (list #$vm))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "mympd") + (test-assert "service is running" + (marionette-eval '(begin + (use-modules (gnu services herd)) + + (start-service 'mympd)) + marionette)) + + (test-assert "HTTP port ready" + (wait-for-tcp-port 80 marionette)) + + (test-equal "http-head" + 200 + (receive (x _) (http-head "http://localhost:8080") (response-code x))) + + (test-end)))) + (gexp->derivation "mympd-test" test)) + +(define %test-mympd + (system-test + (name "mympd") + (description "Connect to a running myMPD service.") + (value (run-mympd-test)))) -- cgit 1.4.1 From 22dd558c70901a336de97187f0470be584571158 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Fri, 27 Jan 2023 21:06:11 +0000 Subject: services: Add hosts-service-type. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/base.scm (): New record type. (host): New procedure. (hosts-service-type): New variable. * doc/guix.texi (Service Reference): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 73 ++++++++++++++++++++++++++++++++++++++++++++++++- gnu/services/base.scm | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 359c9b7a47..9a6a653d86 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -113,7 +113,7 @@ Copyright @copyright{} 2022 Bruno Victal@* Copyright @copyright{} 2022 Ivan Vilata-i-Balaguer@* Copyright @copyright{} 2023 Giacomo Leidi@* Copyright @copyright{} 2022 Antero Mejr@* -Copyright @copyright{} 2022 Bruno Victal@* +Copyright @copyright{} 2023 Bruno Victal@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -40473,6 +40473,77 @@ In this example, the effect would be to add an @file{/etc/issue} file pointing to the given file. @end defvar +@defvar hosts-service-type +Type of the service that populates the entries for (@file{/etc/hosts}). +This service type can be extended by passing it a list of +@code{host} records. + +@c TRANSLATORS: The domain names below SHOULD NOT be translated. +@c They're domains reserved for use in documentation. (RFC6761 Section 6.5) +@c The addresses used are explained in RFC3849 and RFC5737. +@lisp +(simple-service 'add-extra-hosts + hosts-service-type + (list (host "192.0.2.1" "example.com" + '("example.net" "example.org")) + (host "2001:db8::1" "example.com" + '("example.net" "example.org")))) +@end lisp + +@quotation Note +@cindex @file{/etc/host} default entries +By default @file{/etc/host} comes with the following entries: +@example +127.0.0.1 localhost @var{host-name} +::1 localhost @var{host-name} +@end example + +For most setups this is what you want though if you find yourself in +the situation where you want to change the default entries, you can +do so in @code{operating-system}.@pxref{operating-system Reference,@code{essential-services}} + +The following example shows how one would unset @var{host-name} +from being an alias of @code{localhost}. +@lisp +(operating-system + ;; @dots{} + + (essential-services + (modify-services + (operation-system-default-essential-services this-operating-system) + (hosts-service-type config => (list + (host "127.0.0.1" "localhost") + (host "::1" "localhost")))))) +@end lisp +@end quotation + +@deftp {Data Type} host +Available @code{host} fields are: + +@table @asis +@item @code{address} (type: string) +IP address. + +@item @code{canonical-name} (type: string) +Hostname. + +@item @code{aliases} (default: @code{'()}) (type: list-of-string) +Additional aliases that map to the same @code{canonical-name}. + +@end table +@end deftp + +@defun host address canonical-name [aliases] +Procedure for creating @code{host} records. +@end defun + +@quotation Note +The @code{host} data type constructor is @code{%host} though it is +tiresome to create multiple records with it so in practice the procedure +@code{host} (which wraps around @code{%host}) is used instead. +@end quotation +@end defvar + @defvar setuid-program-service-type Type for the ``setuid-program service''. This service collects lists of executable file names, passed as gexps, and adds them to the set of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 9e799445d2..e9fdafd5d0 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2022 Guillaume Le Vaillant ;;; Copyright © 2022 Justin Veilleux ;;; Copyright © 2022 ( +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -103,6 +104,14 @@ console-font-service virtual-terminal-service-type + host + %host + host? + host-address + host-canonical-name + host-aliases + hosts-service-type + static-networking static-networking? static-networking-addresses @@ -685,6 +694,72 @@ to add @var{device} to the kernel's entropy pool. The service will fail if (rngd-configuration (rng-tools rng-tools) (device device)))) + +;;; +;;; /etc/hosts +;;; + +(define (valid-name? name) + "Return true if @var{name} is likely to be a valid host name." + (false-if-exception (not (string-any char-set:whitespace name)))) + +(define-compile-time-procedure (assert-valid-name (name valid-name?)) + "Ensure @var{name} is likely to be a valid host name." + ;; TODO: RFC compliant implementation. + (unless (valid-name? name) + (raise + (make-compound-condition + (formatted-message (G_ "host name '~a' contains invalid characters") + name) + (condition (&error-location + (location + (source-properties->location procedure-call-location))))))) + name) + +(define-record-type* %host + ;; XXX: Using the record type constructor becomes tiresome when + ;; there's multiple records to make. + make-host host? + (address host-address) + (canonical-name host-canonical-name + (sanitize assert-valid-name)) + (aliases host-aliases + (default '()) + (sanitize (cut map assert-valid-name <>)))) + +(define* (host address canonical-name #:optional (aliases '())) + "Return a new record for the host at @var{address} with the given +@var{canonical-name} and possibly @var{aliases}. + +@var{address} must be a string denoting a valid IPv4 or IPv6 address, and +@var{canonical-name} and the strings listed in @var{aliases} must be valid +host names." + (%host + (address address) + (canonical-name canonical-name) + (aliases aliases))) + +(define hosts-service-type + ;; Extend etc-service-type with a entry for @file{/etc/hosts}. + (let* ((serialize-host-record + (lambda (record) + (match-record record (address canonical-name aliases) + (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases)))) + (host-etc-service + (lambda (lst) + `(("hosts" ,(plain-file "hosts" + (format #f "~{~a~}" + (map serialize-host-record + lst)))))))) + (service-type + (name 'etc-hosts) + (extensions + (list + (service-extension etc-service-type + host-etc-service))) + (compose concatenate) + (extend append) + (description "Populate the @file{/etc/hosts} file.")))) ;;; -- cgit 1.4.1 From 802ea1f3a43e5fb8d0b8bd2882954d8a6e49cde6 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Fri, 27 Jan 2023 21:06:12 +0000 Subject: system: Deprecate hosts-file. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system.scm (operating-system-hosts-file): Deprecate procedure. (warn-hosts-file-field-deprecation): New procedure, helper for deprecated variable. (operating-system)[hosts-file]: Use helper to warn deprecated field. (local-host-aliases): Mark as deprecated. (local-host-entries): New procedure. (operating-system-default-essential-services, hurd-default-essential-services): Use hosts-service-type. Use '%operating-system-hosts-file' and 'local-host-entries'. (default-/etc/hosts): Remove procedure. (operating-system-etc-service): Remove hosts file. * doc/guix.texi (operating-system Reference) (Networking Services) (Virtualization Services): Rewrite documentation entries to use hosts-service-type. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 60 ++++++++++++++++++++++++++++------------------------ gnu/system.scm | 59 +++++++++++++++++++++++++++++++++++++++------------ gnu/tests/ganeti.scm | 26 ++++++++++++++--------- 3 files changed, 94 insertions(+), 51 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 9a6a653d86..d1cb6eebf7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16481,13 +16481,6 @@ supported hardware. @item @code{host-name} The host name. -@item @code{hosts-file} -@cindex hosts file -A file-like object (@pxref{G-Expressions, file-like objects}) for use as -@file{/etc/hosts} (@pxref{Host Names,,, libc, The GNU C Library -Reference Manual}). The default is a file with entries for -@code{localhost} and @var{host-name}. - @item @code{mapped-devices} (default: @code{'()}) A list of mapped devices. @xref{Mapped Devices}. @@ -21012,22 +21005,33 @@ line contains a entry that maps a known server name of the Facebook on-line service---e.g., @code{www.facebook.com}---to the local host---@code{127.0.0.1} or its IPv6 equivalent, @code{::1}. -This variable is typically used in the @code{hosts-file} field of an -@code{operating-system} declaration (@pxref{operating-system Reference, -@file{/etc/hosts}}): +This variable is typically used as a @code{hosts-service-type} +service extension (@pxref{Service Reference, @code{hosts-service-type}}): @lisp -(use-modules (gnu) (guix)) +(use-modules (gnu) (gnu services) (guix) (srfi srfi-1) (ice-9 match)) +(use-service-modules networking) (operating-system - (host-name "mymachine") - ;; ... - (hosts-file - ;; Create a /etc/hosts file with aliases for "localhost" - ;; and "mymachine", as well as for Facebook servers. - (plain-file "hosts" - (string-append (local-host-aliases host-name) - %facebook-host-aliases)))) + ;; @dots{} + + (service + (simple-service 'block-facebook-hosts hosts-service-type + (let ((host-pairs + (filter-map + (lambda (x) + (and (not (or (string-null? x) + (string-prefix? "#" x))) + (remove string-null? + (string-split + x + char-set:whitespace)))) + (string-split %facebook-host-aliases #\newline)))) + (map (match-lambda + ((addr name) + (host addr name))) + host-pairs))) + ;; @dots{} @end lisp This mechanism can prevent programs running locally, such as Web @@ -34555,7 +34559,7 @@ and to make maintenance and recovery tasks easy. It consists of multiple services which are described later in this section. In addition to the Ganeti service, you will need the OpenSSH service (@pxref{Networking Services, @code{openssh-service-type}}), and update the @file{/etc/hosts} file -(@pxref{operating-system Reference, @code{hosts-file}}) with the cluster name +(@pxref{Service Reference, @code{hosts-service-type}}) with the cluster name and address (or use a DNS server). All nodes participating in a Ganeti cluster should have the same Ganeti and @@ -34569,14 +34573,6 @@ cluster node that supports multiple storage backends, and installs the (operating-system ;; @dots{} (host-name "node1") - (hosts-file (plain-file "hosts" (format #f " -127.0.0.1 localhost -::1 localhost - -192.168.1.200 ganeti.example.com -192.168.1.201 node1.example.com node1 -192.168.1.202 node2.example.com node2 -"))) ;; Install QEMU so we can use KVM-based instances, and LVM, DRBD and Ceph ;; in order to use the "plain", "drbd" and "rbd" storage backends. @@ -34604,6 +34600,14 @@ cluster node that supports multiple storage backends, and installs the (openssh-configuration (permit-root-login 'prohibit-password))) + (simple-service 'ganeti-hosts-entries hosts-service-type + (list + (host "192.168.1.200" "ganeti.example.com") + (host "192.168.1.201" "node1.example.com" + '("node1")) + (host "192.168.1.202" "node2.example.com" + '("node2")))) + (service ganeti-service-type (ganeti-configuration ;; This list specifies allowed file system paths diff --git a/gnu/system.scm b/gnu/system.scm index d67f9a615b..df60fda53b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -14,6 +14,7 @@ ;;; Copyright © 2020, 2022 Efraim Flashner ;;; Copyright © 2021 Maxime Devos ;;; Copyright © 2021 raid5atemyhomework +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,7 +98,7 @@ operating-system-user-services operating-system-packages operating-system-host-name - operating-system-hosts-file + operating-system-hosts-file ;deprecated operating-system-hurd operating-system-kernel operating-system-kernel-file @@ -169,7 +170,8 @@ read-boot-parameters-file boot-parameters->menu-entry - local-host-aliases + local-host-aliases ;deprecated + local-host-entries %root-account %setuid-programs %sudoers-specification @@ -208,6 +210,15 @@ VERSION is the target version of the boot-parameters record." #$system "/boot"))) ;; System-wide configuration. + +(define-with-syntax-properties (warn-hosts-file-field-deprecation + (value properties)) + (when value + (warning (source-properties->location properties) + (G_ "the 'hosts-file' field is deprecated, please use \ +'hosts-service-type' instead~%"))) + value) + ;; TODO: Add per-field docstrings/stexi. (define-record-type* operating-system make-operating-system @@ -239,8 +250,9 @@ VERSION is the target version of the boot-parameters record." (default %base-firmware)) (host-name operating-system-host-name) ; string - (hosts-file operating-system-hosts-file ; file-like | #f - (default #f)) + (hosts-file %operating-system-hosts-file ; deprecated + (default #f) + (sanitize warn-hosts-file-field-deprecation)) (mapped-devices operating-system-mapped-devices ; list of (default '())) @@ -296,6 +308,10 @@ VERSION is the target version of the boot-parameters record." source-properties->location)) (innate))) +(define-deprecated (operating-system-hosts-file os) + hosts-service-type + (%operating-system-hosts-file os)) + (define* (operating-system-kernel-arguments os root-device #:key (version %boot-parameters-version)) "Return all the kernel arguments, including the ones not specified directly @@ -733,7 +749,8 @@ bookkeeping." (non-boot-fs (non-boot-file-system-service os)) (swaps (swap-services os)) (procs (service user-processes-service-type)) - (host-name (host-name-service (operating-system-host-name os))) + (host-name (operating-system-host-name os)) + (hosts-file (%operating-system-hosts-file os)) (entries (operating-system-directory-base-entries os))) (cons* (service system-service-type entries) (service linux-builder-service-type @@ -755,12 +772,19 @@ bookkeeping." (operating-system-groups os)) (operating-system-skeletons os)) (operating-system-etc-service os) + ;; XXX: hosts-file is deprecated + (if hosts-file + (simple-service 'deprecated-hosts-file etc-service-type + (list `("hosts" ,hosts-file))) + (service hosts-service-type + (local-host-entries host-name))) (service fstab-service-type (filter file-system-needed-for-boot? (operating-system-file-systems os))) (session-environment-service (operating-system-environment-variables os)) - host-name procs root-fs + (host-name-service host-name) + procs root-fs (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type @@ -774,7 +798,9 @@ bookkeeping." (operating-system-firmware os))))))) (define (hurd-default-essential-services os) - (let ((entries (operating-system-directory-base-entries os))) + (let ((host-name (operating-system-host-name os)) + (hosts-file (%operating-system-hosts-file os)) + (entries (operating-system-directory-base-entries os))) (list (service system-service-type entries) %boot-service %hurd-startup-service @@ -794,6 +820,12 @@ bookkeeping." (operating-system-file-systems os))) (pam-root-service (operating-system-pam-services os)) (operating-system-etc-service os) + ;; XXX: hosts-file is deprecated + (if hosts-file + (simple-service 'deprecated-hosts-file etc-service-type + (list `("hosts" ,hosts-file))) + (service hosts-service-type + (local-host-entries host-name))) (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type (operating-system-packages os))))) @@ -912,14 +944,17 @@ of PROVENANCE-SERVICE-TYPE to its services." " This is the GNU system. Welcome.\n") -(define (local-host-aliases host-name) +(define-deprecated (local-host-aliases host-name) + local-host-entries "Return aliases for HOST-NAME, to be used in /etc/hosts." (string-append "127.0.0.1 localhost " host-name "\n" "::1 localhost " host-name "\n")) -(define (default-/etc/hosts host-name) - "Return the default /etc/hosts file." - (plain-file "hosts" (local-host-aliases host-name))) +(define (local-host-entries host-name) + "Return records for @var{host-name}." + (map (lambda (address) + (host address "localhost" (list host-name))) + '("127.0.0.1" "::1"))) (define (validated-sudoers-file file) "Return a copy of FILE, a sudoers file, after checking that it is @@ -1068,8 +1103,6 @@ fi\n"))) ,@(if nsswitch `(("nsswitch.conf" ,#~#$nsswitch)) '()) ("profile" ,#~#$profile) ("bashrc" ,#~#$bashrc) - ("hosts" ,#~#$(or (operating-system-hosts-file os) - (default-/etc/hosts (operating-system-host-name os)))) ;; Write the operating-system-host-name to /etc/hostname to prevent ;; NetworkManager from changing the system's hostname when connecting ;; to certain networks. Some discussion at diff --git a/gnu/tests/ganeti.scm b/gnu/tests/ganeti.scm index f647e9554c..b5624b7598 100644 --- a/gnu/tests/ganeti.scm +++ b/gnu/tests/ganeti.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020, 2021 Marius Bakke ;;; Copyright © 2020 Brice Waegeneire +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module (gnu tests) #:use-module (gnu system vm) #:use-module (gnu services) + #:use-module (gnu services base) #:use-module (gnu services ganeti) #:use-module (gnu services networking) #:use-module (gnu services ssh) @@ -46,18 +48,15 @@ %base-file-systems)) (firmware '()) - ;; The hosts file must contain a nonlocal IP for host-name. - ;; In addition, the cluster name must resolve to an IP address that - ;; is not currently provisioned. - (hosts-file (plain-file "hosts" (format #f " -127.0.0.1 localhost -::1 localhost -10.0.2.15 gnt1.example.com gnt1 -192.168.254.254 ganeti.example.com -"))) - (packages (append (list ganeti-instance-debootstrap ganeti-instance-guix) %base-packages)) + + ;; The hosts file must contain a nonlocal IP for host-name. + (essential-services + (modify-services (operating-system-default-essential-services this-operating-system) + (hosts-service-type config => (list + (host "127.0.0.1" "localhost") + (host "::1" "localhost"))))) (services (append (list (service static-networking-service-type (list %qemu-static-networking)) @@ -65,6 +64,13 @@ (openssh-configuration (permit-root-login 'prohibit-password))) + ;; In addition, the cluster name must resolve to an IP address that + ;; is not currently provisioned. + (simple-service 'ganeti-host-entries hosts-service-type + (list + (host "10.0.2.15" "gnt1.example.com" '("gnt1")) + (host "192.168.254.254" "ganeti.example.com"))) + (service ganeti-service-type (ganeti-configuration (file-storage-paths '("/srv/ganeti/file-storage")) -- cgit 1.4.1 From b0e18601db2daa3c026baa349e5255d4269b5185 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Fri, 27 Jan 2023 21:06:13 +0000 Subject: services: Add block-facebook-hosts-service-type. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Deprecates %facebook-host-aliases in favour of using hosts-service-type service extensions. * gnu/services/networking.scm (block-facebook-hosts-service-type): New variable. (%facebook-host-aliases): Deprecate variable. * doc/guix.texi: Document it. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 38 ++++----------------------- gnu/services/networking.scm | 64 ++++++++++++++++++++++----------------------- 2 files changed, 37 insertions(+), 65 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index d1cb6eebf7..96b396b58c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -20998,42 +20998,14 @@ Logging level. @end table @end deftp -@defvar %facebook-host-aliases -This variable contains a string for use in @file{/etc/hosts} -(@pxref{Host Names,,, libc, The GNU C Library Reference Manual}). Each -line contains a entry that maps a known server name of the Facebook +@defvar block-facebook-hosts-service-type +This service type adds a list of known Facebook hosts to the +@file{/etc/hosts} file. +(@pxref{Host Names,,, libc, The GNU C Library Reference Manual}) +Each line contains a entry that maps a known server name of the Facebook on-line service---e.g., @code{www.facebook.com}---to the local host---@code{127.0.0.1} or its IPv6 equivalent, @code{::1}. -This variable is typically used as a @code{hosts-service-type} -service extension (@pxref{Service Reference, @code{hosts-service-type}}): - -@lisp -(use-modules (gnu) (gnu services) (guix) (srfi srfi-1) (ice-9 match)) -(use-service-modules networking) - -(operating-system - ;; @dots{} - - (service - (simple-service 'block-facebook-hosts hosts-service-type - (let ((host-pairs - (filter-map - (lambda (x) - (and (not (or (string-null? x) - (string-prefix? "#" x))) - (remove string-null? - (string-split - x - char-set:whitespace)))) - (string-split %facebook-host-aliases #\newline)))) - (map (match-lambda - ((addr name) - (host addr name))) - host-pairs))) - ;; @dots{} -@end lisp - This mechanism can prevent programs running locally, such as Web browsers, from accessing Facebook. @end defvar diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 89ce16f6af..dacf64c2d1 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2021 Guillaume Le Vaillant ;;; Copyright © 2022, 2023 Andrew Tropin ;;; Copyright © 2023 Declan Tsien +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -80,7 +81,9 @@ #:use-module (json) #:re-export (static-networking-service static-networking-service-type) - #:export (%facebook-host-aliases + #:export (%facebook-host-aliases ;deprecated + block-facebook-hosts-service-type + dhcp-client-service-type dhcp-client-configuration dhcp-client-configuration? @@ -235,39 +238,36 @@ ;;; ;;; Code: -(define %facebook-host-aliases +(define facebook-host-aliases ;; This is the list of known Facebook hosts to be added to /etc/hosts if you ;; are to block it. - "\ -# Block Facebook IPv4. -127.0.0.1 www.facebook.com -127.0.0.1 facebook.com -127.0.0.1 login.facebook.com -127.0.0.1 www.login.facebook.com -127.0.0.1 fbcdn.net -127.0.0.1 www.fbcdn.net -127.0.0.1 fbcdn.com -127.0.0.1 www.fbcdn.com -127.0.0.1 static.ak.fbcdn.net -127.0.0.1 static.ak.connect.facebook.com -127.0.0.1 connect.facebook.net -127.0.0.1 www.connect.facebook.net -127.0.0.1 apps.facebook.com - -# Block Facebook IPv6. -fe80::1%lo0 facebook.com -fe80::1%lo0 login.facebook.com -fe80::1%lo0 www.login.facebook.com -fe80::1%lo0 fbcdn.net -fe80::1%lo0 www.fbcdn.net -fe80::1%lo0 fbcdn.com -fe80::1%lo0 www.fbcdn.com -fe80::1%lo0 static.ak.fbcdn.net -fe80::1%lo0 static.ak.connect.facebook.com -fe80::1%lo0 connect.facebook.net -fe80::1%lo0 www.connect.facebook.net -fe80::1%lo0 apps.facebook.com\n") - + (let ((domains '("facebook.com" "www.facebook.com" + "login.facebook.com" "www.login.facebook.com" + "fbcdn.net" "www.fbcdn.net" "fbcdn.com" "www.fbcdn.com" + "static.ak.fbcdn.net" "static.ak.connect.facebook.com" + "connect.facebook.net" "www.connect.facebook.net" + "apps.facebook.com"))) + (append-map (lambda (name) + (map (lambda (addr) + (host addr name)) + (list "127.0.0.1" "::1"))) domains))) + +(define-deprecated %facebook-host-aliases + block-facebook-hosts-service-type + (string-join + (map (lambda (x) + (string-append (host-address x) "\t" + (host-canonical-name x) "\n")) + facebook-host-aliases))) + +(define block-facebook-hosts-service-type + (service-type + (name 'block-facebook-hosts) + (extensions + (list (service-extension hosts-service-type + (const facebook-host-aliases)))) + (default-value #f) + (description "Add a list of known Facebook hosts to @file{/etc/hosts}"))) (define-record-type* dhcp-client-configuration make-dhcp-client-configuration -- cgit 1.4.1 From 8a2c2eaa906bd12d9c804ba18ac305b9719507ef Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Fri, 13 Jan 2023 21:34:58 +0000 Subject: services: lightdm: Sync documentation with source. Table entry @item nodes cannot span multiple lines. * gnu/services/lightdm.scm (lightdm-gtk-greeter-configuration): Fix cursor-theme-size description. * doc/guix.texi (lightdm-service-type): Sync with source. Signed-off-by: Maxim Cournoyer --- doc/guix.texi | 12 ++++-------- gnu/services/lightdm.scm | 2 +- 2 files changed, 5 insertions(+), 9 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 96b396b58c..5fb5850a6c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -21844,7 +21844,7 @@ disable security: @end lisp Or to set a PasswordFile for the classic (unsecure) VncAuth -mecanism: +mechanism: @lisp (vnc-server-command (file-append tigervnc-server "/bin/Xvnc" @@ -21880,9 +21880,7 @@ Available @code{lightdm-gtk-greeter-configuration} fields are: @item @code{lightdm-gtk-greeter} (default: @code{lightdm-gtk-greeter}) (type: file-like) The lightdm-gtk-greeter package to use. -@item @code{assets} @ -(default: @code{(adwaita-icon-theme gnome-themes-extrahicolor-icon-theme)}) @ -(type: list-of-file-likes) +@item @code{assets} (default: @code{(adwaita-icon-theme gnome-themes-extra hicolor-icon-theme)}) (type: list-of-file-likes) The list of packages complementing the greeter, such as package providing icon themes. @@ -21908,8 +21906,7 @@ The background image to use. Enable accessibility support through the Assistive Technology Service Provider Interface (AT-SPI). -@item @code{a11y-states} @ -(default: @code{(contrast font keyboard reader)}) (type: list-of-a11y-states) +@item @code{a11y-states} (default: @code{(contrast font keyboard reader)}) (type: list-of-a11y-states) The accessibility features to enable, given as list of symbols. @item @code{reader} (type: maybe-file-like) @@ -21943,8 +21940,7 @@ The type of the seat, either the @code{local} or @code{xremote} symbol. @item @code{autologin-user} (type: maybe-string) The username to automatically log in with by default. -@item @code{greeter-session} @ -(default: @code{lightdm-gtk-greeter}) (type: greeter-session) +@item @code{greeter-session} (default: @code{lightdm-gtk-greeter}) (type: greeter-session) The greeter session to use, specified as a symbol. Currently, only @code{lightdm-gtk-greeter} is supported. diff --git a/gnu/services/lightdm.scm b/gnu/services/lightdm.scm index 7e3864fec2..0b9094cda1 100644 --- a/gnu/services/lightdm.scm +++ b/gnu/services/lightdm.scm @@ -151,7 +151,7 @@ icon themes." "The name of the cursor theme to use.") (cursor-theme-size (number 16) - "The size to use for the the cursor theme.") + "The size to use for the cursor theme.") (allow-debugging? maybe-boolean "Set to #t to enable debug log level.") -- cgit 1.4.1 From fe554337de7fa739165958e655fa6fb9dc73cf06 Mon Sep 17 00:00:00 2001 From: Remco van 't Veer Date: Sat, 11 Feb 2023 12:16:09 +0100 Subject: doc: Fix documentation typo. * doc/guix.texi (Service Reference): Fix typo. Signed-off-by: Julien Lepiller --- 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 5fb5850a6c..6c7c918eb0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -40482,7 +40482,7 @@ from being an alias of @code{localhost}. (essential-services (modify-services - (operation-system-default-essential-services this-operating-system) + (operating-system-default-essential-services this-operating-system) (hosts-service-type config => (list (host "127.0.0.1" "localhost") (host "::1" "localhost")))))) -- cgit 1.4.1 From dbd4d2d0707b486f1e2c8659e94e1d3b15e4351e Mon Sep 17 00:00:00 2001 From: Pierre Langlois Date: Fri, 25 Nov 2022 01:57:21 +0000 Subject: build-system: Add tree-sitter-build-system. * guix/build-system/tree-sitter.scm: New module. * guix/build/tree-sitter-build-system.scm: Likewise. * Makefile.am (MODULES): Add them. * doc/guix.texi: Document it. Signed-off-by: Andrew Tropin --- Makefile.am | 2 + doc/guix.texi | 21 +++- guix/build-system/tree-sitter.scm | 195 ++++++++++++++++++++++++++++++++ guix/build/tree-sitter-build-system.scm | 153 +++++++++++++++++++++++++ 4 files changed, 370 insertions(+), 1 deletion(-) create mode 100644 guix/build-system/tree-sitter.scm create mode 100644 guix/build/tree-sitter-build-system.scm (limited to 'doc') diff --git a/Makefile.am b/Makefile.am index a4b6f03b3a..5ce6cc84f4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -178,6 +178,7 @@ MODULES = \ guix/build-system/ruby.scm \ guix/build-system/scons.scm \ guix/build-system/texlive.scm \ + guix/build-system/tree-sitter.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ guix/http-client.scm \ @@ -234,6 +235,7 @@ MODULES = \ guix/build/ruby-build-system.scm \ guix/build/scons-build-system.scm \ guix/build/texlive-build-system.scm \ + guix/build/tree-sitter-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ guix/build/julia-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 6c7c918eb0..44e2165a82 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, 2021 Pierre Langlois@* +Copyright @copyright{} 2020, 2021, 2022 Pierre Langlois@* Copyright @copyright{} 2020 pinoaffe@* Copyright @copyright{} 2020 André Batista@* Copyright @copyright{} 2020, 2021 Alexandru-Sergiu Marton@* @@ -9756,6 +9756,25 @@ be specified with the @code{#:node} parameter which defaults to @code{node}. @end defvar +@defvr {Scheme Variable} tree-sitter-build-system + +This variable is exported by @code{(guix build-system tree-sitter)}. It +implements procedures to compile grammars for the +@url{https://tree-sitter.github.io/tree-sitter/, Tree-sitter} parsing +library. It essentially runs @code{tree-sitter generate} to translate +@code{grammar.js} grammars to JSON and then to C. Which it then +compiles to native code. + +Tree-sitter packages may support multiple grammars, so this build system +supports a @code{#:grammar-directories} keyword to specify a list of +locations where a @code{grammar.js} file may be found. + +Grammars sometimes depend on each other, such as C++ depending on C and +TypeScript depending on JavaScript. You may use inputs to declare such +dependencies. + +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, diff --git a/guix/build-system/tree-sitter.scm b/guix/build-system/tree-sitter.scm new file mode 100644 index 0000000000..21c4eb35b2 --- /dev/null +++ b/guix/build-system/tree-sitter.scm @@ -0,0 +1,195 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Pierre Langlois +;;; +;;; 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 build-system tree-sitter) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix build-system node) + #:use-module (ice-9 match) + #:export (%tree-sitter-build-system-modules + tree-sitter-build + tree-sitter-build-system)) + +(define %tree-sitter-build-system-modules + ;; Build-side modules imported by default. + `((guix build tree-sitter-build-system) + ,@%node-build-system-modules)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + `(#:inputs #:native-inputs #:outputs ,@(if target + '() + '(#:target)))) + (define node + (module-ref (resolve-interface '(gnu packages node)) + 'node-lts)) + (define tree-sitter + (module-ref (resolve-interface '(gnu packages tree-sitter)) + 'tree-sitter)) + (define tree-sitter-cli + (module-ref (resolve-interface '(gnu packages tree-sitter)) + 'tree-sitter-cli)) + ;; Grammars depend on each other via JS modules, which we package into a + ;; dedicated js output. + (define grammar-inputs + (map (match-lambda + ((name package) + `(,name ,package "js"))) + inputs)) + (bag + (name name) + (system system) (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ("node" ,node) + ("tree-sitter-cli" ,tree-sitter-cli) + ,@native-inputs + ,@(if target '() grammar-inputs) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(if target + (standard-cross-packages target 'host) + '()) + ,@(standard-packages))) + (host-inputs `(("tree-sitter" ,tree-sitter) + ,@(if target grammar-inputs '()))) + ;; Keep the standard inputs of 'gnu-buid-system'. + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + ;; XXX: this is a hack to get around issue #41569. + (outputs (match outputs + (("out") (cons "js" outputs)) + (_ outputs))) + (build (if target tree-sitter-cross-build tree-sitter-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define* (tree-sitter-build name inputs + #:key + source + (phases '%standard-phases) + (grammar-directories '(".")) + (tests? #t) + (outputs '("out" "js")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %tree-sitter-build-system-modules) + (modules '((guix build utils) + (guix build tree-sitter-build-system)))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (tree-sitter-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:tests? #$tests? + #:grammar-directories '#$grammar-directories + #:outputs #$(outputs->gexp outputs) + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define* (tree-sitter-cross-build name + #:key + target + build-inputs target-inputs host-inputs + guile source + (phases '%standard-phases) + (grammar-directories '(".")) + (tests? #t) + (outputs '("out" "js")) + (search-paths '()) + (native-search-paths '()) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules + %tree-sitter-build-system-modules) + (modules + '((guix build utils) + (guix build tree-sitter-build-system)))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (tree-sitter-build #:name #$name + #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:phases #$phases + #:tests? #$tests? + #:grammar-directories '#$grammar-directories + #:outputs #$(outputs->gexp outputs) + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths ' + #$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(sexp->gexp + (map + search-path-specification->sexp + native-search-paths)))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:guile-for-build guile))) + +(define tree-sitter-build-system + (build-system + (name 'tree-sitter) + (description "The Tree-sitter grammar build system") + (lower lower))) + +;;; tree-sitter.scm ends here diff --git a/guix/build/tree-sitter-build-system.scm b/guix/build/tree-sitter-build-system.scm new file mode 100644 index 0000000000..4106728bdf --- /dev/null +++ b/guix/build/tree-sitter-build-system.scm @@ -0,0 +1,153 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Pierre Langlois +;;; +;;; 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 build tree-sitter-build-system) + #:use-module ((guix build node-build-system) #:prefix node:) + #:use-module (guix build json) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:export (%standard-phases + tree-sitter-build)) + +;; Commentary: +;; +;; Build procedures for tree-sitter grammar packages. This is the +;; builder-side code, which builds on top of the node build-system. +;; +;; Tree-sitter grammars are written in JavaScript and compiled to a native +;; shared object. The `tree-sitter generate' command invokes `node' in order +;; to evaluate the grammar.js into a grammar.json file, which is then +;; translated into C code. We then compile the C code ourselves. Packages +;; also sometimes add extra manually written C/C++ code. +;; +;; In order to support grammars depending on each other, such as C and C++, +;; JavaScript and TypeScript, this build-system installs the source of the +;; node module in a dedicated "js" output. +;; +;; Code: + +(define* (patch-dependencies #:key inputs #:allow-other-keys) + "Rewrite dependencies in 'package.json'. We remove all runtime dependencies +and replace development dependencies with tree-sitter grammar node modules." + + (define (rewrite package.json) + (map (match-lambda + (("dependencies" @ . _) + '("dependencies" @)) + (("devDependencies" @ . _) + `("devDependencies" @ + ,@(filter-map (match-lambda + ((key . directory) + (let ((node-module + (string-append directory + "/lib/node_modules/" + key))) + (and (directory-exists? node-module) + `(,key . ,node-module))))) + (alist-delete "node" inputs)))) + (other other)) + package.json)) + + (node:with-atomic-json-file-replacement "package.json" + (match-lambda + (('@ . package.json) + (cons '@ (rewrite package.json)))))) + +;; FIXME: The node build-system's configure phase does not support +;; cross-compiling so we re-define it. +(define* (configure #:key native-inputs inputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--offline" "--ignore-scripts" "install")) + +(define* (build #:key grammar-directories #:allow-other-keys) + (for-each (lambda (dir) + (with-directory-excursion dir + ;; Avoid generating binding code for other languages, we do + ;; not support this use-case yet and it relies on running + ;; `node-gyp' to build native addons. + (invoke "tree-sitter" "generate" "--no-bindings"))) + grammar-directories)) + +(define* (check #:key grammar-directories tests? #:allow-other-keys) + (when tests? + (for-each (lambda (dir) + (with-directory-excursion dir + (invoke "tree-sitter" "test"))) + grammar-directories))) + +(define* (install #:key target grammar-directories outputs #:allow-other-keys) + (let ((lib (string-append (assoc-ref outputs "out") + "/lib/tree-sitter"))) + (mkdir-p lib) + (define (compile-language dir) + (with-directory-excursion dir + (let ((lang (assoc-ref (call-with-input-file "src/grammar.json" + read-json) + "name")) + (source-file (lambda (path) + (if (file-exists? path) + path + #f)))) + (apply invoke + `(,(if target + (string-append target "-g++") + "g++") + "-shared" + "-fPIC" + "-fno-exceptions" + "-O2" + "-g" + "-o" ,(string-append lib "/libtree-sitter-" lang ".so") + ;; An additional `scanner.{c,cc}' file is sometimes + ;; provided. + ,@(cond + ((source-file "src/scanner.c") + => (lambda (file) (list "-xc" "-std=c99" file))) + ((source-file "src/scanner.cc") + => (lambda (file) (list file))) + (else '())) + "-xc" "src/parser.c"))))) + (for-each compile-language grammar-directories))) + +(define* (install-js #:key native-inputs inputs outputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--prefix" (assoc-ref outputs "js") + "--global" + "--offline" + "--loglevel" "info" + "--production" + ;; Skip scripts to prevent building bindings via GYP. + "--ignore-scripts" + "install" "../package.tgz")) + +(define %standard-phases + (modify-phases node:%standard-phases + (replace 'patch-dependencies patch-dependencies) + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'install-js install-js))) + +(define* (tree-sitter-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + (apply node:node-build #:inputs inputs #:phases phases args)) + +;;; tree-sitter-build-system.scm ends here -- cgit 1.4.1 From 598f4c509bbfec2b983a8ee246cce0a0fe45ec7f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 21 Jan 2023 15:04:09 -0500 Subject: pack: Add RPM format. * guix/rpm.scm: New file. * guix/scripts/pack.scm (rpm-archive): New procedure. (%formats): Register it. (show-formats): Add it. (guix-pack): Register supported extra-options for the rpm format. * tests/pack.scm (rpm-for-tests): New variable. ("rpm archive can be installed/uninstalled"): New test. * tests/rpm.scm: New test. * doc/guix.texi (Invoking guix pack): Document it. --- Makefile.am | 2 + doc/guix.texi | 46 +++- guix/rpm.scm | 623 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 230 ++++++++++++++++++- tests/pack.scm | 57 ++++- tests/rpm.scm | 86 +++++++ 6 files changed, 1031 insertions(+), 13 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm (limited to 'doc') diff --git a/Makefile.am b/Makefile.am index 5ce6cc84f4..8e3815b9c2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,6 +111,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/rpm.scm \ guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ @@ -535,6 +536,7 @@ SCM_TESTS = \ tests/pypi.scm \ tests/read-print.scm \ tests/records.scm \ + tests/rpm.scm \ tests/scripts.scm \ tests/search-paths.scm \ tests/services.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 44e2165a82..05615b9549 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6896,6 +6896,7 @@ such file or directory'' message. @end quotation @item deb +@cindex Debian, build a .deb package with guix pack This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. @@ -6912,7 +6913,8 @@ guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello Because archives produced with @command{guix pack} contain a collection of store items and because each @command{dpkg} package must not have conflicting files, in practice that means you likely won't be able to -install more than one such archive on a given system. +install more than one such archive on a given system. You can +nonetheless pack as many Guix packages as you want in one such archive. @end quotation @quotation Warning @@ -6923,6 +6925,48 @@ shared by other software, such as a Guix installation or other, non-deb packs. @end quotation +@item rpm +@cindex RPM, build an RPM archive with guix pack +This produces an RPM archive (a package with the @samp{.rpm} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any RPM-based GNU/Linux distribution. +The RPM format embeds checksums for every file it contains, which the +@command{rpm} command uses to validate the integrity of the archive. + +Advanced RPM-related options are revealed via the +@option{--help-rpm-format} option. These options allow embedding +maintainer scripts that can run before or after the installation of the +RPM archive, for example. + +The RPM format supports relocatable packages via the @option{--prefix} +option of the @command{rpm} command, which can be handy to install an +RPM package to a specific prefix. + +@example +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello +@end example + +@example +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm +@end example + +@quotation Note +Contrary to Debian packages, conflicting but @emph{identical} files in +RPM packages can be installed simultaneously, which means multiple +@command{guix pack}-produced RPM packages can usually be installed side +by side without any problem. +@end quotation + +@quotation Warning +@command{rpm} assumes ownership of any files contained in the pack, +which means it will remove @file{/gnu/store} upon uninstalling a +Guix-generated RPM package, unless the RPM package was installed with +the @option{--prefix} option of the @command{rpm} command. It is unwise +to install Guix-produced @samp{.rpm} packages on a system where +@file{/gnu/store} is shared by other software, such as a Guix +installation or other, non-rpm packs. +@end quotation + @end table @cindex relocatable binaries diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..1cb8326a9b --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,623 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; 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 rpm) + #:autoload (gcrypt hash) (hash-algorithm file-hash md5) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:export (generate-lead + generate-signature + generate-header + assemble-rpm-metadata + + ;; XXX: These are internals, but the inline disabling trick + ;; doesn't work on them. + make-header-entry + header-entry? + header-entry-tag + header-entry-count + header-entry-value + + bytevector->hex-string + + fhs-directory?)) + +;;; Commentary: +;;; +;;; This module provides the building blocks required to construct RPM +;;; archives. It is intended to be importable on the build side, so shouldn't +;;; depend on (guix diagnostics) or other host-side-only modules. +;;; +;;; Code: + +(define (gnu-system-triplet->machine-type triplet) + "Return the machine component of TRIPLET, a GNU system triplet." + (first (string-split triplet #\-))) + +(define (gnu-machine-type->rpm-arch type) + "Return the canonical RPM architecture string, given machine TYPE." + (match type + ("arm" "armv7hl") + ("powerpc" "ppc") + ("powerpc64le" "ppc64le") + (machine machine))) ;unchanged + +(define (gnu-machine-type->rpm-number type) + "Translate machine TYPE to its corresponding RPM integer value." + ;; Refer to the rpmrc.in file in the RPM source for the complete + ;; translation tables. + (match type + ((or "i486" "i586" "i686" "x86_64") 1) + ((? (cut string-prefix? "powerpc" <>)) 5) + ("mips64el" 11) + ((? (cut string-prefix? "arm" <>)) 12) + ("aarch64" 19) + ((? (cut string-prefix? "riscv" <>)) 22) + (_ (error "no RPM number known for machine type" type)))) + +(define (u16-number->u8-list number) + "Return a list of byte values made of NUMBER, a 16 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 2))) + (bytevector->u8-list bv))) + +(define (u32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (s32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit signed integer." + (let ((bv (sint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (u8-list->u32-number lst) + "Return the 32 bit unsigned integer corresponding to the 4 bytes in LST." + (bytevector-u32-ref (u8-list->bytevector lst) 0 (endianness big))) + + +;;; +;;; Lead section. +;;; + +;; Refer to the docs/manual/format.md file of the RPM source for the details +;; regarding the binary format of an RPM archive. +(define* (generate-lead name-version #:key (target %host-type)) + "Generate a RPM lead u8-list that uses NAME-VERSION, the name and version +string of the package, and TARGET, a GNU triplet used to derive the target +machine type." + (define machine-type (gnu-system-triplet->machine-type target)) + (define magic (list #xed #xab #xee #xdb)) + (define file-format-version (list 3 0)) ;3.0 + (define type (list 0 0)) ;0 for binary packages + (define arch-number (u16-number->u8-list + (gnu-machine-type->rpm-number machine-type))) + ;; The 66 bytes from 10 to 75 are for the name-version-release string. + (define name + (let ((padding-bytes (make-list (- 66 (string-length name-version)) 0))) + (append (bytevector->u8-list (string->utf8 name-version)) + padding-bytes))) + ;; There is no OS number corresponding to GNU/Hurd (GNU), only Linux, per + ;; rpmrc.in. + (define os-number (list 0 1)) + + ;; For RPM format 3.0, the signature type is 5, which means a "Header-style" + ;; signature. + (define signature-type (list 0 5)) + + (define reserved-bytes (make-list 16 0)) + + (append magic file-format-version type arch-number name + os-number signature-type reserved-bytes)) + + +;;; +;;; Header section. +;;; + +(define header-magic (list #x8e #xad #xe8)) +(define header-version (list 1)) +(define header-reserved (make-list 4 0)) ;4 reserved bytes +;;; Every header starts with 8 bytes made by the header magic number, the +;;; header version and 4 reserved bytes. +(define header-intro (append header-magic header-version header-reserved)) + +;;; Header entry data types. +(define NULL 0) +(define CHAR 1) +(define INT8 2) +(define INT16 3) ;2-bytes aligned +(define INT32 4) ;4-bytes aligned +(define INT64 5) ;8-bytes aligned +(define STRING 6) +(define BIN 7) +(define STRING_ARRAY 8) +(define I18NSTRIN_TYPE 9) + +;;; Header entry tags. +(define-record-type + (make-rpm-tag number type) + rpm-tag? + (number rpm-tag-number) + (type rpm-tag-type)) + +;;; The following are internal tags used to identify the data sections. +(define RPMTAG_HEADERSIGNATURES (make-rpm-tag 62 BIN)) ;signature header +(define RPMTAG_HEADERIMMUTABLE (make-rpm-tag 63 BIN)) ;main/data header +(define RPMTAG_HEADERI18NTABLE (make-rpm-tag 100 STRING_ARRAY)) + +;;; Subset of RPM tags from include/rpm/rpmtag.h. +(define RPMTAG_NAME (make-rpm-tag 1000 STRING)) +(define RPMTAG_VERSION (make-rpm-tag 1001 STRING)) +(define RPMTAG_RELEASE (make-rpm-tag 1002 STRING)) +(define RPMTAG_SUMMARY (make-rpm-tag 1004 STRING)) +(define RPMTAG_SIZE (make-rpm-tag 1009 INT32)) +(define RPMTAG_LICENSE (make-rpm-tag 1014 STRING)) +(define RPMTAG_OS (make-rpm-tag 1021 STRING)) +(define RPMTAG_ARCH (make-rpm-tag 1022 STRING)) +(define RPMTAG_PREIN (make-rpm-tag 1023 STRING)) +(define RPMTAG_POSTIN (make-rpm-tag 1024 STRING)) +(define RPMTAG_PREUN (make-rpm-tag 1025 STRING)) +(define RPMTAG_POSTUN (make-rpm-tag 1026 STRING)) +(define RPMTAG_FILESIZES (make-rpm-tag 1028 INT32)) +(define RPMTAG_FILEMODES (make-rpm-tag 1030 INT16)) +(define RPMTAG_FILEDIGESTS (make-rpm-tag 1035 STRING_ARRAY)) +(define RPMTAG_FILELINKTOS (make-rpm-tag 1036 STRING_ARRAY)) +(define RPMTAG_FILEUSERNAME (make-rpm-tag 1039 STRING_ARRAY)) +(define RPMTAG_GROUPNAME (make-rpm-tag 1040 STRING_ARRAY)) +(define RPMTAG_PREFIXES (make-rpm-tag 1098 STRING_ARRAY)) +(define RPMTAG_DIRINDEXES (make-rpm-tag 1116 INT32)) +(define RPMTAG_BASENAMES (make-rpm-tag 1117 STRING_ARRAY)) +(define RPMTAG_DIRNAMES (make-rpm-tag 1118 STRING_ARRAY)) +(define RPMTAG_PAYLOADFORMAT (make-rpm-tag 1124 STRING)) +(define RPMTAG_PAYLOADCOMPRESSOR (make-rpm-tag 1125 STRING)) +(define RPMTAG_LONGFILESIZES (make-rpm-tag 5008 INT64)) +(define RPMTAG_LONGSIZE (make-rpm-tag 5009 INT64)) +;;; The algorithm used to compute the digest of each file, e.g. RPM_HASH_MD5. +(define RPMTAG_FILEDIGESTALGO (make-rpm-tag 5011 INT32)) +;;; RPMTAG_ENCODING specifies the encoding used for strings, e.g. "utf-8". +(define RPMTAG_ENCODING (make-rpm-tag 5062 STRING)) +;;; Compressed payload digest. Its type is a string array, but currently in +;;; practice it is equivalent to STRING, since only the first element is used. +(define RPMTAG_PAYLOADDIGEST (make-rpm-tag 5092 STRING_ARRAY)) +;;; The algorithm used to compute the payload digest, e.g. RPM_HASH_SHA256. +(define RPMTAG_PAYLOADDIGESTALGO (make-rpm-tag 5093 INT32)) +;;; The following are taken from the rpmHashAlgo_e enum in rpmcrypto.h. +(define RPM_HASH_MD5 1) +(define RPM_HASH_SHA256 8) + +;;; Other useful internal definitions. +(define REGION_TAG_COUNT 16) ;number of bytes +(define INT32_MAX (1- (expt 2 32))) ;4294967295 bytes (unsigned) + +(define (rpm-tag->u8-list tag) + "Return the u8 list corresponding to RPM-TAG, a object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ; + (count header-entry-count) ;number (u32) + (value header-entry-value)) ;string|number|list|... + +(define (entry-type->alignement type) + "Return the byte alignment of TYPE, an RPM header entry type." + (cond ((= INT16 type) 2) + ((= INT32 type) 4) + ((= INT64 type) 8) + (else 1))) + +(define (next-aligned-offset offset alignment) + "Return the next position from OFFSET which satisfies ALIGNMENT." + (if (= 0 (modulo offset alignment)) + offset + (next-aligned-offset (1+ offset) alignment))) + +(define (header-entry->data entry) + "Return the data of ENTRY, a object, as a u8 list." + (let* ((tag (header-entry-tag entry)) + (count (header-entry-count entry)) + (value (header-entry-value entry)) + (number (rpm-tag-number tag)) + (type (rpm-tag-type tag))) + (cond + ((= STRING type) + (unless (string? value) + (error "expected string value for STRING type, got" value)) + (unless (= 1 count) + (error "count must be 1 for STRING type")) + (let ((value (cond ((= (rpm-tag-number RPMTAG_VERSION) number) + ;; Hyphens are not allowed in version strings. + (string-map (match-lambda + (#\- #\+) + (c c)) + value)) + (else value)))) + (append (bytevector->u8-list (string->utf8 value)) + (list 0)))) ;strings must end with null byte + ((= STRING_ARRAY type) + (unless (list? value) + (error "expected a list of strings for STRING_ARRAY type, got" value)) + (unless (= count (length value)) + (error "expected count to be equal to" (length value) 'got count)) + (append-map (lambda (s) + (append (bytevector->u8-list (string->utf8 s)) + (list 0))) ;null byte separated + value)) + ((member type (list INT8 INT16 INT32)) + (if (= 1 count) + (unless (number? value) + (error "expected number value for scalar INT type; got" value)) + (unless (list? value) + (error "expected list value for array INT type; got" value))) + (if (list? value) + (cond ((= INT8 type) value) + ((= INT16 type) (append-map u16-number->u8-list value)) + ((= INT32 type) (append-map u32-number->u8-list value)) + (else (error "unexpected type" type))) + (cond ((= INT8 type) (list value)) + ((= INT16 type) (u16-number->u8-list value)) + ((= INT32 type) (u32-number->u8-list value)) + (else (error "unexpected type" type))))) + ((= BIN type) + (unless (list? value) + (error "expected list value for BIN type; got" value)) + value) + (else (error "unimplemented type" type))))) + +(define (make-header-index+data entries) + "Return the index and data sections as u8 number lists, via multiple values. +An index is composed of four u32 (16 bytes total) quantities, in order: tag, +type, offset and count." + (match (fold (match-lambda* + ((entry (offset . (index . data))) + (let* ((tag (header-entry-tag entry)) + (tag-number (rpm-tag-number tag)) + (tag-type (rpm-tag-type tag)) + (count (header-entry-count entry)) + (data* (header-entry->data entry)) + (alignment (entry-type->alignement tag-type)) + (aligned-offset (next-aligned-offset offset alignment)) + (padding (make-list (- aligned-offset offset) 0))) + (cons (+ aligned-offset (length data*)) + (cons (append index + (u32-number->u8-list tag-number) + (u32-number->u8-list tag-type) + (u32-number->u8-list aligned-offset) + (u32-number->u8-list count)) + (append data padding data*)))))) + '(0 . (() . ())) + entries) + ((offset . (index . data)) + (values index data)))) + +;; Prevent inlining of the variables/procedures accessed by unit tests. +(set! make-header-index+data make-header-index+data) +(set! RPMTAG_ARCH RPMTAG_ARCH) +(set! RPMTAG_LICENSE RPMTAG_LICENSE) +(set! RPMTAG_NAME RPMTAG_NAME) +(set! RPMTAG_OS RPMTAG_OS) +(set! RPMTAG_RELEASE RPMTAG_RELEASE) +(set! RPMTAG_SUMMARY RPMTAG_SUMMARY) +(set! RPMTAG_VERSION RPMTAG_VERSION) + +(define (wrap-in-region-tags header region-tag) + "Wrap HEADER, a header provided as u8-list with REGION-TAG." + (let* ((type (rpm-tag-type region-tag)) + (header-intro (take header 16)) + (header-rest (drop header 16)) + ;; Increment the existing index value to account for the added region + ;; tag index. + (index-length (1+ (u8-list->u32-number + (drop-right (drop header-intro 8) 4)))) ;bytes 8-11 + ;; Increment the data length value to account for the added region + ;; tag data. + (data-length (+ REGION_TAG_COUNT + (u8-list->u32-number + (take-right header-intro 4))))) ;last 4 bytes of intro + (unless (member region-tag (list RPMTAG_HEADERSIGNATURES + RPMTAG_HEADERIMMUTABLE)) + (error "expected RPMTAG_HEADERSIGNATURES or RPMTAG_HEADERIMMUTABLE, got" + region-tag)) + (append (drop-right header-intro 8) ;strip existing index and data lengths + (u32-number->u8-list index-length) + (u32-number->u8-list data-length) + ;; Region tag (16 bytes). + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (u32-number->u8-list (- data-length REGION_TAG_COUNT)) ;offset + (u32-number->u8-list REGION_TAG_COUNT) ;count + ;; Immutable region. + header-rest + ;; Region tag trailer (16 bytes). Note: the trailer offset value + ;; is an enforced convention; it has no practical use. + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (s32-number->u8-list (* -1 index-length 16)) ;negative offset + (u32-number->u8-list REGION_TAG_COUNT)))) ;count + +(define (bytevector->hex-string bv) + (format #f "~{~2,'0x~}" (bytevector->u8-list bv))) + +(define (files->md5-checksums files) + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." + (let ((file-md5 (cut file-hash (hash-algorithm md5) <>))) + (map (lambda (f) + (or (and=> (false-if-exception (file-md5 f)) + bytevector->hex-string) + ;; Only regular files (e.g., not directories) can have their + ;; checksum computed. + "")) + files))) + +(define (strip-leading-dot name) + "Remove the leading \".\" from NAME, if present. If a single \".\" is +encountered, translate it to \"/\"." + (match name + ("." "/") ;special case + ((? (cut string-prefix? "." <>)) + (string-drop name 1)) + (x name))) + +;;; An extensive list of required and optional FHS directories, per its 3.0 +;;; revision. +(define %fhs-directories + (list "/bin" "/boot" "/dev" + "/etc" "/etc/opt" "/etc/X11" "/etc/sgml" "/etc/xml" + "/home" "/root" "/lib" "/media" "/mnt" + "/opt" "/opt/bin" "/opt/doc" "/opt/include" + "/opt/info" "/opt/lib" "/opt/man" + "/run" "/sbin" "/srv" "/sys" "/tmp" + "/usr" "/usr/bin" "/usr/include" "/usr/libexec" + "/usr/share/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" "/usr/share/misc" + "/usr/share/nls" "/usr/share/ppd" "/usr/share/sgml" + "/usr/share/terminfo" "/usr/share/tmac" "/usr/share/xml" + "/usr/share/zoneinfo" "/usr/local" "/usr/local/bin" "/usr/local/etc" + "/usr/local/games" "/usr/local/include" "/usr/local/lib" + "/usr/local/man" "/usr/local/sbin" "/usr/local/sbin" "/usr/local/share" + "/usr/local/src" "/var" "/var/account" "/var/backups" + "/var/cache" "/var/cache/fonts" "/var/cache/man" "/var/cache/www" + "/var/crash" "/var/cron" "/var/games" "/var/mail" "/var/msgs" + "/var/lib" "/var/lib/color" "/var/lib/hwclock" "/var/lib/misc" + "/var/local" "/var/lock" "/var/log" "/var/opt" "/var/preserve" + "/var/run" "/var/spool" "/var/spool/lpd" "/var/spool/mqueue" + "/var/spool/news" "/var/spool/rwho" "/var/spool/uucp" + "/var/tmp" "/var/yp")) + +(define (fhs-directory? file-name) + "Predicate to check if FILE-NAME is a known File Hierarchy Standard (FHS) +directory." + (member (strip-leading-dot file-name) %fhs-directories)) + +(define (directory->file-entries directory) + "Return the file lists triplet header entries for the files found under +DIRECTORY." + (with-directory-excursion directory + ;; Skip the initial "." directory, as its name would get concatenated with + ;; the "./" dirname and fail to match "." in the payload. + (let* ((files (cdr (find-files "." #:directories? #t))) + (file-stats (map lstat files)) + (directories + (append (list ".") + (filter-map (match-lambda + ((index . file) + (let ((st (list-ref file-stats index))) + (and (eq? 'directory (stat:type st)) + file)))) + (list-transduce (tenumerate) rcons files)))) + ;; Omit any FHS directories found in FILES to avoid the RPM package + ;; from owning them. This can occur when symlinks directives such + ;; as "/usr/bin/hello -> bin/hello" are used. + (package-files package-file-stats + (unzip2 (reverse + (fold (lambda (file stat res) + (if (fhs-directory? file) + res + (cons (list file stat) res))) + '() files file-stats)))) + + ;; When provided with the index of a file, the directory index must + ;; return the index of the corresponding directory entry. + (dirindexes (map (lambda (d) + (list-index (cut string=? <> d) directories)) + (map dirname package-files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename package-files)) + ;; The directory names must end with a trailing "/". + (dirnames (map (compose strip-leading-dot (cut string-append <> "/")) + directories)) + ;; Note: All the file-related entries must have the same length as + ;; the basenames entry. + (symlink-targets (map (lambda (f) + (if (symbolic-link? f) + (readlink f) + "")) ;unused + package-files)) + (file-modes (map stat:mode package-file-stats)) + (file-sizes (map stat:size package-file-stats)) + (file-md5s (files->md5-checksums package-files))) + (let ((basenames-length (length basenames)) + (dirindexes-length (length dirindexes))) + (unless (= basenames-length dirindexes-length) + (error "length mismatch for dirIndexes; expected/actual" + basenames-length dirindexes-length)) + (append + (if (> (apply max file-sizes) INT32_MAX) + (list (make-header-entry RPMTAG_LONGFILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_LONGSIZE 1 + (reduce + 0 file-sizes))) + (list (make-header-entry RPMTAG_FILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_SIZE 1 (reduce + 0 file-sizes)))) + (list + (make-header-entry RPMTAG_FILEMODES (length file-modes) file-modes) + (make-header-entry RPMTAG_FILEDIGESTS (length file-md5s) file-md5s) + (make-header-entry RPMTAG_FILEDIGESTALGO 1 RPM_HASH_MD5) + (make-header-entry RPMTAG_FILELINKTOS (length symlink-targets) + symlink-targets) + (make-header-entry RPMTAG_FILEUSERNAME basenames-length + (make-list basenames-length "root")) + (make-header-entry RPMTAG_GROUPNAME basenames-length + (make-list basenames-length "root")) + ;; The dirindexes, basenames and dirnames tags form the so-called RPM + ;; "path triplet". + (make-header-entry RPMTAG_DIRINDEXES dirindexes-length dirindexes) + (make-header-entry RPMTAG_BASENAMES basenames-length basenames) + (make-header-entry RPMTAG_DIRNAMES (length dirnames) dirnames))))))) + +(define (make-header entries) + "Return the u8 list of a RPM header containing ENTRIES, a list of + objects." + (let* ((entries (sort entries (lambda (x y) + (< (rpm-tag-number (header-entry-tag x)) + (rpm-tag-number (header-entry-tag y)))))) + (count (length entries)) + (index data (make-header-index+data entries))) + (append header-intro ;8 bytes + (u32-number->u8-list count) ;4 bytes + (u32-number->u8-list (length data)) ;4 bytes + ;; Now starts the header index, which can contain up to 32 entries + ;; of 16 bytes each. + index data))) + +(define* (generate-header name version + payload-digest + payload-directory + payload-compressor + #:key + relocatable? + prein-file postin-file + preun-file postun-file + (target %host-type) + (release "0") + (license "N/A") + (summary "RPM archive generated by GNU Guix.") + (os "Linux")) ;see rpmrc.in + "Return the u8 list corresponding to the Header section. PAYLOAD-DIGEST is +the SHA256 checksum string of the compressed payload. PAYLOAD-DIRECTORY is +the directory containing the payload files. PAYLOAD-COMPRESSOR is the name of +the compressor used to compress the CPIO payload, such as \"none\", \"gz\", +\"xz\" or \"zstd\"." + (let* ((rpm-arch (gnu-machine-type->rpm-arch + (gnu-system-triplet->machine-type target))) + (file->string (cut call-with-input-file <> get-string-all)) + (prein-script (and=> prein-file file->string)) + (postin-script (and=> postin-file file->string)) + (preun-script (and=> preun-file file->string)) + (postun-script (and=> postun-file file->string))) + (wrap-in-region-tags + (make-header (append + (list (make-header-entry RPMTAG_HEADERI18NTABLE 1 (list "C")) + (make-header-entry RPMTAG_NAME 1 name) + (make-header-entry RPMTAG_VERSION 1 version) + (make-header-entry RPMTAG_RELEASE 1 release) + (make-header-entry RPMTAG_SUMMARY 1 summary) + (make-header-entry RPMTAG_LICENSE 1 license) + (make-header-entry RPMTAG_OS 1 os) + (make-header-entry RPMTAG_ARCH 1 rpm-arch)) + (directory->file-entries payload-directory) + (if relocatable? + ;; Note: RPMTAG_PREFIXES must not have a trailing + ;; slash, unless it's '/'. This allows installing the + ;; package via 'rpm -i --prefix=/tmp', for example. + (list (make-header-entry RPMTAG_PREFIXES 1 (list "/"))) + '()) + (if prein-script + (list (make-header-entry RPMTAG_PREIN 1 prein-script)) + '()) + (if postin-script + (list (make-header-entry RPMTAG_POSTIN 1 postin-script)) + '()) + (if preun-script + (list (make-header-entry RPMTAG_PREUN 1 preun-script)) + '()) + (if postun-script + (list (make-header-entry RPMTAG_POSTUN 1 postun-script)) + '()) + (if (string=? "none" payload-compressor) + '() + (list (make-header-entry RPMTAG_PAYLOADCOMPRESSOR 1 + payload-compressor))) + (list (make-header-entry RPMTAG_ENCODING 1 "utf-8") + (make-header-entry RPMTAG_PAYLOADFORMAT 1 "cpio") + (make-header-entry RPMTAG_PAYLOADDIGEST 1 + (list payload-digest)) + (make-header-entry RPMTAG_PAYLOADDIGESTALGO 1 + RPM_HASH_SHA256)))) + RPMTAG_HEADERIMMUTABLE))) + + +;;; +;;; Signature section +;;; + +;;; Header sha256 checksum. +(define RPMSIGTAG_SHA256 (make-rpm-tag 273 STRING)) +;;; Uncompressed payload size. +(define RPMSIGTAG_PAYLOADSIZE (make-rpm-tag 1007 INT32)) +;;; Header and compressed payload combined size. +(define RPMSIGTAG_SIZE (make-rpm-tag 1000 INT32)) +;;; Uncompressed payload size (when size > max u32). +(define RPMSIGTAG_LONGARCHIVESIZE (make-rpm-tag 271 INT64)) +;;; Header and compressed payload combined size (when size > max u32). +(define RPMSIGTAG_LONGSIZE (make-rpm-tag 270 INT64)) +;;; Extra space reserved for signatures (typically 32 bytes). +(define RPMSIGTAG_RESERVEDSPACE (make-rpm-tag 1008 BIN)) + +(define (generate-signature header-sha256 + header+compressed-payload-size + ;; uncompressed-payload-size + ) + "Return the u8 list representing a signature header containing the +HEADER-SHA256 (a string) and the PAYLOAD-SIZE, which is the combined size of +the header and compressed payload." + (define size-tag (if (> header+compressed-payload-size INT32_MAX) + RPMSIGTAG_LONGSIZE + RPMSIGTAG_SIZE)) + (wrap-in-region-tags + (make-header (list (make-header-entry RPMSIGTAG_SHA256 1 header-sha256) + (make-header-entry size-tag 1 + header+compressed-payload-size) + ;; (make-header-entry RPMSIGTAG_PAYLOADSIZE 1 + ;; uncompressed-payload-size) + ;; Reserve 32 bytes of extra space in case users would + ;; like to add signatures, as done in rpmGenerateSignature. + (make-header-entry RPMSIGTAG_RESERVEDSPACE 32 + (make-list 32 0)))) + RPMTAG_HEADERSIGNATURES)) + +(define (assemble-rpm-metadata lead signature header) + "Align and append the various u8 list components together, and return the +result as a bytevector." + (let* ((offset (+ (length lead) (length signature))) + (header-offset (next-aligned-offset offset 8)) + (padding (make-list (- header-offset offset) 0))) + ;; The Header is 8-bytes aligned. + (u8-list->bytevector (append lead signature padding header)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 77425e5b0f..701e41ff1a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer ;;; Copyright © 2020 Eric Bavier ;;; Copyright © 2022 Alex Griffin ;;; @@ -67,6 +67,7 @@ self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -856,6 +857,166 @@ Section: misc ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (ice-9 optargs) + (rnrs bytevectors) + (srfi srfi-1)) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name + (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version + (or (and=> single-entry manifest-entry-version) "0.0.0")) + + (define lead + (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest + (bytevector->hex-string (file-sha256 #$payload))) + + (let-keywords '#$extra-options #f ((relocatable? #f) + (prein-file #f) + (postin-file #f) + (preun-file #f) + (postun-file #f)) + + (let ((header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? relocatable? + #:prein-file prein-file + #:postin-file postin-file + #:preun-file preun-file + #:postun-file postun-file))) + + (define header-sha256 + (bytevector->hex-string (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size + (+ (length header) payload-size)) + + (define signature + (generate-signature header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + +;;; ;;; Compiling C programs. ;;; @@ -1187,7 +1348,8 @@ last resort for relocation." `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1201,18 +1363,22 @@ last resort for relocation." docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1231,6 +1397,32 @@ last resort for relocation." (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1307,7 +1499,12 @@ last resort for relocation." (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1325,6 +1522,7 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1483,6 +1681,16 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/tests/pack.scm b/tests/pack.scm index a02924b7d2..734ae1c69b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus -;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021, 2023 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,13 +28,16 @@ #:use-module (guix tests) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages linux) #:select (fakeroot)) #:use-module (srfi srfi-64)) (define %store @@ -59,6 +62,17 @@ (define %ar-bootstrap %bootstrap-binutils) +;;; This is a variant of the RPM package configured so that its database can +;;; be created on a writable location readily available inside the build +;;; container ("/tmp"). +(define rpm-for-tests + (package + (inherit rpm) + (arguments (substitute-keyword-arguments (package-arguments rpm) + ((#:configure-flags flags '()) + #~(cons "--localstatedir=/tmp" + (delete "--localstatedir=/var" #$flags))))))) + (test-begin "pack") @@ -355,6 +369,47 @@ (stat "postinst")))))) (assert (file-exists? "triggers")) + (mkdir #$output)))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "rpm archive can be installed/uninstalled" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (rpm-pack (rpm-archive "rpm-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/bin/guile" -> "bin/guile")) + #:extra-options '(#:relocatable? #t))) + (check + (gexp->derivation "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. (mkdir #$output)))))) (built-derivations (list check))))) diff --git a/tests/rpm.scm b/tests/rpm.scm new file mode 100644 index 0000000000..f40b36fe60 --- /dev/null +++ b/tests/rpm.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; 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 (test-rpm) + #:use-module (guix rpm) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71)) + +;; For white-box testing. +(define-syntax-rule (expose-internal name) + (define name (@@ (guix rpm) name))) + +(expose-internal RPMTAG_ARCH) +(expose-internal RPMTAG_LICENSE) +(expose-internal RPMTAG_NAME) +(expose-internal RPMTAG_OS) +(expose-internal RPMTAG_RELEASE) +(expose-internal RPMTAG_SUMMARY) +(expose-internal RPMTAG_VERSION) +(expose-internal header-entry-count) +(expose-internal header-entry-tag) +(expose-internal header-entry-value) +(expose-internal header-entry?) +(expose-internal make-header) +(expose-internal make-header-entry) +(expose-internal make-header-index+data) + +(test-begin "rpm") + +(test-equal "lead must be 96 bytes long" + 96 + (length (generate-lead "hello-2.12.1"))) + +(define header-entries + (list (make-header-entry RPMTAG_NAME 1 "hello") + (make-header-entry RPMTAG_VERSION 1 "2.12.1") + (make-header-entry RPMTAG_RELEASE 1 "0") + (make-header-entry RPMTAG_SUMMARY 1 + "Hello, GNU world: An example GNU package") + (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later") + (make-header-entry RPMTAG_OS 1 "Linux") + (make-header-entry RPMTAG_ARCH 1 "x86_64"))) + +(define expected-header-index-length + (* 16 (length header-entries))) ;16 bytes per index entry + +(define expected-header-data-length + (+ (length header-entries) ;to account for null bytes + (fold + 0 (map (compose string-length (cut header-entry-value <>)) + header-entries)))) + +(let ((index data (make-header-index+data header-entries))) + (test-equal "header index" + expected-header-index-length + (length index)) + + ;; This test depends on the fact that only STRING entries are used, and that + ;; they are composed of single byte characters and the delimiting null byte. + (test-equal "header data" + expected-header-data-length + (length data))) + +(test-equal "complete header section" + (+ 16 ;leading magic + count bytes + expected-header-index-length expected-header-data-length) + (length (make-header header-entries))) + +(test-end) -- cgit 1.4.1 From ce02b23bb9412239e3eb318c266047ef4e95e870 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Tue, 21 Feb 2023 21:37:07 +0000 Subject: doc: hosts-service-type: Relocate to Base Services. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit hosts-service-type is under (gnu services base) * doc/guix.texi: Merge duplicated copyright lines. (Service Reference): Move hosts-service-type to ... (Base Services): ... here. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 145 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 72 insertions(+), 73 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 05615b9549..4143488b93 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -109,11 +109,10 @@ Copyright @copyright{} 2022 Reily Siegel@* Copyright @copyright{} 2022 Simon Streit@* Copyright @copyright{} 2022 (@* Copyright @copyright{} 2022 John Kehayias@* -Copyright @copyright{} 2022 Bruno Victal@* +Copyright @copyright{} 2022⁠–⁠2023 Bruno Victal@* Copyright @copyright{} 2022 Ivan Vilata-i-Balaguer@* Copyright @copyright{} 2023 Giacomo Leidi@* Copyright @copyright{} 2022 Antero Mejr@* -Copyright @copyright{} 2023 Bruno Victal@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -18021,6 +18020,77 @@ package or any valid argument to @command{setfont}, as in this example: @end lisp @end defvar +@defvar hosts-service-type +Type of the service that populates the entries for (@file{/etc/hosts}). +This service type can be extended by passing it a list of +@code{host} records. + +@c TRANSLATORS: The domain names below SHOULD NOT be translated. +@c They're domains reserved for use in documentation. (RFC6761 Section 6.5) +@c The addresses used are explained in RFC3849 and RFC5737. +@lisp +(simple-service 'add-extra-hosts + hosts-service-type + (list (host "192.0.2.1" "example.com" + '("example.net" "example.org")) + (host "2001:db8::1" "example.com" + '("example.net" "example.org")))) +@end lisp + +@quotation Note +@cindex @file{/etc/host} default entries +By default @file{/etc/host} comes with the following entries: +@example +127.0.0.1 localhost @var{host-name} +::1 localhost @var{host-name} +@end example + +For most setups this is what you want though if you find yourself in +the situation where you want to change the default entries, you can +do so in @code{operating-system}.@pxref{operating-system Reference,@code{essential-services}} + +The following example shows how one would unset @var{host-name} +from being an alias of @code{localhost}. +@lisp +(operating-system + ;; @dots{} + + (essential-services + (modify-services + (operating-system-default-essential-services this-operating-system) + (hosts-service-type config => (list + (host "127.0.0.1" "localhost") + (host "::1" "localhost")))))) +@end lisp +@end quotation + +@deftp {Data Type} host +Available @code{host} fields are: + +@table @asis +@item @code{address} (type: string) +IP address. + +@item @code{canonical-name} (type: string) +Hostname. + +@item @code{aliases} (default: @code{'()}) (type: list-of-string) +Additional aliases that map to the same @code{canonical-name}. + +@end table +@end deftp + +@defun host address canonical-name [aliases] +Procedure for creating @code{host} records. +@end defun + +@quotation Note +The @code{host} data type constructor is @code{%host} though it is +tiresome to create multiple records with it so in practice the procedure +@code{host} (which wraps around @code{%host}) is used instead. +@end quotation +@end defvar + @deffn {Scheme Procedure} login-service @var{config} Return a service to run login according to @var{config}, a @code{} object, which specifies the message of the day, @@ -40508,77 +40578,6 @@ In this example, the effect would be to add an @file{/etc/issue} file pointing to the given file. @end defvar -@defvar hosts-service-type -Type of the service that populates the entries for (@file{/etc/hosts}). -This service type can be extended by passing it a list of -@code{host} records. - -@c TRANSLATORS: The domain names below SHOULD NOT be translated. -@c They're domains reserved for use in documentation. (RFC6761 Section 6.5) -@c The addresses used are explained in RFC3849 and RFC5737. -@lisp -(simple-service 'add-extra-hosts - hosts-service-type - (list (host "192.0.2.1" "example.com" - '("example.net" "example.org")) - (host "2001:db8::1" "example.com" - '("example.net" "example.org")))) -@end lisp - -@quotation Note -@cindex @file{/etc/host} default entries -By default @file{/etc/host} comes with the following entries: -@example -127.0.0.1 localhost @var{host-name} -::1 localhost @var{host-name} -@end example - -For most setups this is what you want though if you find yourself in -the situation where you want to change the default entries, you can -do so in @code{operating-system}.@pxref{operating-system Reference,@code{essential-services}} - -The following example shows how one would unset @var{host-name} -from being an alias of @code{localhost}. -@lisp -(operating-system - ;; @dots{} - - (essential-services - (modify-services - (operating-system-default-essential-services this-operating-system) - (hosts-service-type config => (list - (host "127.0.0.1" "localhost") - (host "::1" "localhost")))))) -@end lisp -@end quotation - -@deftp {Data Type} host -Available @code{host} fields are: - -@table @asis -@item @code{address} (type: string) -IP address. - -@item @code{canonical-name} (type: string) -Hostname. - -@item @code{aliases} (default: @code{'()}) (type: list-of-string) -Additional aliases that map to the same @code{canonical-name}. - -@end table -@end deftp - -@defun host address canonical-name [aliases] -Procedure for creating @code{host} records. -@end defun - -@quotation Note -The @code{host} data type constructor is @code{%host} though it is -tiresome to create multiple records with it so in practice the procedure -@code{host} (which wraps around @code{%host}) is used instead. -@end quotation -@end defvar - @defvar setuid-program-service-type Type for the ``setuid-program service''. This service collects lists of executable file names, passed as gexps, and adds them to the set of -- cgit 1.4.1 From 4372abfb0fc6ab80b1cc5d866b5889afe9d99758 Mon Sep 17 00:00:00 2001 From: Bruno Victal Date: Tue, 21 Feb 2023 21:37:09 +0000 Subject: doc: hosts-service-type: Improve documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi (Base Services): Improve hosts-service-type documentation. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 4143488b93..85768a4b60 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -18022,7 +18022,7 @@ package or any valid argument to @command{setfont}, as in this example: @defvar hosts-service-type Type of the service that populates the entries for (@file{/etc/hosts}). -This service type can be extended by passing it a list of +This service type can be @emph{extended} by passing it a list of @code{host} records. @c TRANSLATORS: The domain names below SHOULD NOT be translated. @@ -18047,10 +18047,11 @@ By default @file{/etc/host} comes with the following entries: For most setups this is what you want though if you find yourself in the situation where you want to change the default entries, you can -do so in @code{operating-system}.@pxref{operating-system Reference,@code{essential-services}} +do so in @code{operating-system} via @code{modify-services} +(@pxref{Service Reference,@code{modify-services}}). -The following example shows how one would unset @var{host-name} -from being an alias of @code{localhost}. +The following example shows how to unset @var{host-name} from being an +alias of @code{localhost}. @lisp (operating-system ;; @dots{} @@ -18085,9 +18086,9 @@ Procedure for creating @code{host} records. @end defun @quotation Note -The @code{host} data type constructor is @code{%host} though it is -tiresome to create multiple records with it so in practice the procedure -@code{host} (which wraps around @code{%host}) is used instead. +The constructor for the @code{host} record-type is @code{%host} though +the procedure @code{host} results in more concise definitions when there are +multiple @code{host} records. @end quotation @end defvar -- cgit 1.4.1 From 35e64a87937c9bae12b207d50cb28f199211a5d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Feb 2023 16:10:24 +0100 Subject: services: hosts: Do not export '%host'. This was not meant to be exported. * gnu/services/base.scm (%host): Do not export. * doc/guix.texi (Base Services): Remove mention. --- doc/guix.texi | 6 ------ gnu/services/base.scm | 1 - 2 files changed, 7 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 85768a4b60..fa4d94c1d7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -18084,12 +18084,6 @@ Additional aliases that map to the same @code{canonical-name}. @defun host address canonical-name [aliases] Procedure for creating @code{host} records. @end defun - -@quotation Note -The constructor for the @code{host} record-type is @code{%host} though -the procedure @code{host} results in more concise definitions when there are -multiple @code{host} records. -@end quotation @end defvar @deffn {Scheme Procedure} login-service @var{config} diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3f55feb5a0..35b03a877b 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -106,7 +106,6 @@ virtual-terminal-service-type host - %host host? host-address host-canonical-name -- cgit 1.4.1 From 810788b5509cf4ab7c2d6b70c0a416880301d837 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Feb 2023 16:15:49 +0100 Subject: doc: Further clarify documentation of 'host' and 'hosts-service-type'. * doc/guix.texi (Base Services): Use docstring of 'host' to document it and remove @deftp. Introduce example. Fix typos in file name. --- doc/guix.texi | 30 +++++++++++------------------- 1 file changed, 11 insertions(+), 19 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index fa4d94c1d7..73ebbfa8f4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -18025,6 +18025,8 @@ Type of the service that populates the entries for (@file{/etc/hosts}). This service type can be @emph{extended} by passing it a list of @code{host} records. +The example below shows how to add two entries to @file{/etc/hosts}: + @c TRANSLATORS: The domain names below SHOULD NOT be translated. @c They're domains reserved for use in documentation. (RFC6761 Section 6.5) @c The addresses used are explained in RFC3849 and RFC5737. @@ -18038,8 +18040,8 @@ This service type can be @emph{extended} by passing it a list of @end lisp @quotation Note -@cindex @file{/etc/host} default entries -By default @file{/etc/host} comes with the following entries: +@cindex @file{/etc/hosts} default entries +By default @file{/etc/hosts} comes with the following entries: @example 127.0.0.1 localhost @var{host-name} ::1 localhost @var{host-name} @@ -18064,27 +18066,17 @@ alias of @code{localhost}. (host "::1" "localhost")))))) @end lisp @end quotation +@end defvar -@deftp {Data Type} host -Available @code{host} fields are: - -@table @asis -@item @code{address} (type: string) -IP address. - -@item @code{canonical-name} (type: string) -Hostname. - -@item @code{aliases} (default: @code{'()}) (type: list-of-string) -Additional aliases that map to the same @code{canonical-name}. -@end table -@end deftp +@defun host @var{address} @var{canonical-name} [@var{aliases}] +Return a new record for the host at @var{address} with the given +@var{canonical-name} and possibly @var{aliases}. -@defun host address canonical-name [aliases] -Procedure for creating @code{host} records. +@var{address} must be a string denoting a valid IPv4 or IPv6 address, and +@var{canonical-name} and the strings listed in @var{aliases} must be valid +host names. @end defun -@end defvar @deffn {Scheme Procedure} login-service @var{config} Return a service to run login according to @var{config}, a -- cgit 1.4.1 From c756c62cfdba8d4079be1ba9e370779b850f16b6 Mon Sep 17 00:00:00 2001 From: André Batista Date: Fri, 17 Feb 2023 16:06:40 -0300 Subject: doc: Explain how to use local guix repositories. * doc/guix.texi (Using a Custom Guix Channel): Add note and example on how to exempt a local guix repository from git ownership checks. Signed-off-by: Maxim Cournoyer --- doc/guix.texi | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 73ebbfa8f4..a7ef00f421 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,7 +81,7 @@ Copyright @copyright{} 2020, 2021 Brice Waegeneire@* Copyright @copyright{} 2020 R Veera Kumar@* Copyright @copyright{} 2020, 2021, 2022 Pierre Langlois@* Copyright @copyright{} 2020 pinoaffe@* -Copyright @copyright{} 2020 André Batista@* +Copyright @copyright{} 2020, 2023 André Batista@* Copyright @copyright{} 2020, 2021 Alexandru-Sergiu Marton@* Copyright @copyright{} 2020 raingloom@* Copyright @copyright{} 2020 Daniel Brooks@* @@ -5412,6 +5412,25 @@ From there on, @command{guix pull} will fetch code from the @code{super-hacks} branch of the repository at @code{example.org}. The authentication concern is addressed below (@pxref{Channel Authentication}). +Note that you can specify a local directory on the @code{url} field above if +the channel that you intend to use resides on a local file system. However, +in this case @command{guix} checks said directory for ownership before any +further processing. This means that if the user is not the directory owner, +but wants to use it as their default, they will then need to set it as a safe +directory in their global git configuration file. Otherwise, @command{guix} +will refuse to even read it. Supposing your system-wide local directory is at +@code{/src/guix.git}, you would then create a git configuration file at +@code{~/.gitconfig} with the following contents: + +@example +[safe] + directory = /src/guix.git +@end example + +@noindent +This also applies to the root user unless when called with @command{sudo} by +the directory owner. + @node Replicating Guix @section Replicating Guix -- cgit 1.4.1 From 6118c1e2289d9b9ab24b9d82891628f519ae3d01 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 28 Feb 2023 18:11:08 +0100 Subject: services: Add sugar-desktop-service-type. * gnu/services/desktop.scm (sugar-desktop-service-type): New variable. (sugar-polkit-settings, sugar-desktop-configuration, make-sugar-desktop-configuration, sugar-desktop-configuration?, sugar-package): New procedures. (): New record. * doc/guix.texi (Desktop Services): Document it. --- doc/guix.texi | 22 +++++++++++++++++++++- gnu/services/desktop.scm | 32 +++++++++++++++++++++++++++++++- 2 files changed, 52 insertions(+), 2 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a7ef00f421..73e3d1aa92 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -30,7 +30,7 @@ Copyright @copyright{} 2015, 2016 Mathieu Lirzin@* Copyright @copyright{} 2014 Pierre-Antoine Rault@* Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/Kammer@* Copyright @copyright{} 2015, 2016, 2017, 2019, 2020, 2021, 2023 Leo Famulari@* -Copyright @copyright{} 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Ricardo Wurmus@* +Copyright @copyright{} 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023 Ricardo Wurmus@* Copyright @copyright{} 2016 Ben Woodcroft@* Copyright @copyright{} 2016, 2017, 2018, 2021 Chris Marusich@* Copyright @copyright{} 2016, 2017, 2018, 2019, 2020, 2021, 2022 Efraim Flashner@* @@ -23180,6 +23180,26 @@ The LXQT package to use. @end table @end deftp +@defvar sugar-desktop-service-type +This is the type of the service that runs the +@uref{https://www.sugarlabs.org, Sugar desktop environment}. Its value +is a @code{sugar-desktop-configuration} object (see below). + +This service adds the @code{sugar} package to the system profile. It +does not install any Sugar Activity. Add packages providing activities +to the list of packages to be installed globally to make them available +to users of the Sugar desktop environment. +@end defvar + +@deftp {Data Type} sugar-desktop-configuration +Configuration record for the Sugar desktop environment. + +@table @asis +@item @code{sugar} (default: @code{sugar}) +The Sugar package to use. +@end table +@end deftp + @defvar enlightenment-desktop-service-type Return a service that adds the @code{enlightenment} package to the system profile, and extends dbus with actions from @code{efl}. diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 2034b3d099..42f35e9a75 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -6,7 +6,7 @@ ;;; Copyright © 2017, 2020, 2022, 2023 Maxim Cournoyer ;;; Copyright © 2017 Nikita ;;; Copyright © 2018, 2020, 2022 Efraim Flashner -;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018, 2023 Ricardo Wurmus ;;; Copyright © 2017, 2019 Christopher Baines ;;; Copyright © 2019 Tim Gesthuizen ;;; Copyright © 2019 David Wilson @@ -59,6 +59,7 @@ #:use-module (gnu packages xdisorg) #:use-module (gnu packages scanner) #:use-module (gnu packages suckless) + #:use-module (gnu packages sugar) #:use-module (gnu packages linux) #:use-module (gnu packages libusb) #:use-module (gnu packages lxqt) @@ -144,6 +145,10 @@ lxqt-desktop-configuration? lxqt-desktop-service-type + sugar-desktop-configuration + sugar-desktop-configuration? + sugar-desktop-service-type + xfce-desktop-configuration xfce-desktop-configuration? xfce-desktop-service @@ -1517,6 +1522,31 @@ rules." (default-value (lxqt-desktop-configuration)) (description "Run LXQt desktop environment."))) + +;;; +;;; Sugar desktop service. +;;; + +(define-record-type* sugar-desktop-configuration + make-sugar-desktop-configuration + sugar-desktop-configuration? + (sugar sugar-package (default sugar))) + +(define (sugar-polkit-settings config) + "Return the list of packages that provide polkit actions and rules." + (list (sugar-package config))) + +(define sugar-desktop-service-type + (service-type + (name 'sugar-desktop) + (extensions + (list (service-extension polkit-service-type + sugar-polkit-settings) + (service-extension profile-service-type + (compose list sugar-package)))) + (default-value (sugar-desktop-configuration)) + (description "Run the Sugar desktop environment."))) + ;;; ;;; X11 socket directory service -- cgit 1.4.1 From d7f9eb0e876257b28672057bea3561fef2fe5c0f Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 28 Feb 2023 23:14:23 +0100 Subject: gnu: sugar-desktop-configuration: Allow specification of activities. * gnu/services/desktop.scm (): Add new fields for activities and gobject-introspection. (sugar-gobject-introspection, sugar-activities): New procedures. (sugar-desktop-service-type): Install packages for activities and gobject-introspection alongside the sugar package. * doc/guix.texi (Desktop Services): Document changes. --- doc/guix.texi | 31 +++++++++++++++++++++++++++---- gnu/services/desktop.scm | 11 +++++++++-- 2 files changed, 36 insertions(+), 6 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 73e3d1aa92..6ff525d0ff 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -23185,10 +23185,9 @@ This is the type of the service that runs the @uref{https://www.sugarlabs.org, Sugar desktop environment}. Its value is a @code{sugar-desktop-configuration} object (see below). -This service adds the @code{sugar} package to the system profile. It -does not install any Sugar Activity. Add packages providing activities -to the list of packages to be installed globally to make them available -to users of the Sugar desktop environment. +This service adds the @code{sugar} package to the system profile, as +well as any selected Sugar activities. By default it only includes a +minimal set of activities. @end defvar @deftp {Data Type} sugar-desktop-configuration @@ -23197,9 +23196,33 @@ Configuration record for the Sugar desktop environment. @table @asis @item @code{sugar} (default: @code{sugar}) The Sugar package to use. +@item @code{gobject-introspection} (default: @code{gobject-introspection}) +The @code{gobject-introspection} package to use. This package is used +to access libraries installed as dependencies of Sugar activities. +@item @code{activities} (default: @code{(list sugar-help-activity)}) +A list of Sugar activities to install. @end table @end deftp +The following example configures the Sugar desktop environment with a +number of useful activities: + +@lisp +(use-modules (gnu)) +(use-package-modules sugar) +(use-service-modules desktop) +(operating-system + ... + (services (cons* (service sugar-desktop-service-type + (sugar-desktop-configuration + (activities (list sugar-browse-activity + sugar-help-activity + sugar-jukebox-activity + sugar-typing-turtle-activity)))) + %desktop-services)) + ...) +@end lisp + @defvar enlightenment-desktop-service-type Return a service that adds the @code{enlightenment} package to the system profile, and extends dbus with actions from @code{efl}. diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 42f35e9a75..4724294433 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -1530,7 +1530,11 @@ rules." (define-record-type* sugar-desktop-configuration make-sugar-desktop-configuration sugar-desktop-configuration? - (sugar sugar-package (default sugar))) + (sugar sugar-package (default sugar)) + (gobject-introspection + sugar-gobject-introspection (default gobject-introspection)) + (activities + sugar-activities (default (list sugar-help-activity)))) (define (sugar-polkit-settings config) "Return the list of packages that provide polkit actions and rules." @@ -1543,7 +1547,10 @@ rules." (list (service-extension polkit-service-type sugar-polkit-settings) (service-extension profile-service-type - (compose list sugar-package)))) + (lambda (config) + (cons* (sugar-package config) + (sugar-gobject-introspection config) + (sugar-activities config)))))) (default-value (sugar-desktop-configuration)) (description "Run the Sugar desktop environment."))) -- cgit 1.4.1