From 3c2d2b453832167df02f4aa25de4857a003fbecf Mon Sep 17 00:00:00 2001 From: muradm Date: Tue, 23 Aug 2022 23:13:55 +0300 Subject: gnu: security: Add fail2ban-service-type. * gnu/services/security.scm: New module. * gnu/tests/security.scm: New module. * gnu/local.mk: Add new security module and tests. * doc/guix.text: Add fail2ban-service-type documentation. Signed-off-by: Maxim Cournoyer --- doc/guix.texi | 249 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 249 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 7bce8a567c..4f6973518f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -36311,6 +36311,255 @@ Extra command line options for @code{nix-service-type}. @end table @end deftp +@cindex Fail2Ban +@subsubheading Fail2Ban service + +@uref{http://www.fail2ban.org/, @code{fail2ban}} scans log files +(e.g. @code{/var/log/apache/error_log}) and bans IP addresses that show +malicious signs -- repeated password failures, attempts to make use of +exploits, etc. + +@code{fail2ban-service-type} service type is provided by the @code{(gnu +services security)} module. + +This service type runs the @code{fail2ban} daemon. It can be configured +in various ways, which are: + +@table @asis +@item Basic configuration +The basic parameters of the Fail2Ban service can be configured via its +@code{fail2ban} configuration, which is documented below. + +@item User-specified jail extensions +The @code{fail2ban-jail-service} function can be used to add new +Fail2Ban jails. + +@item Shepherd extension mechanism +Service developers can extend the @code{fail2ban-service-type} service +type itself via the usual service extension mechanism. +@end table + +@defvr {Scheme Variable} fail2ban-service-type + +This is the type of the service that runs @code{fail2ban} daemon. Below +is an example of a basic, explicit configuration: + +@lisp +(append + (list + (service fail2ban-service-type + (fail2ban-configuration + (extra-jails + (list + (fail2ban-jail-configuration + (name "sshd") + (enabled #t)))))) + ;; There is no implicit dependency on an actual SSH + ;; service, so you need to provide one. + (service openssh-service-type)) + %base-services) +@end lisp +@end defvr + +@deffn {Scheme Procedure} fail2ban-jail-service @var{svc-type} @var{jail} +Extend @var{svc-type}, a @code{} object with @var{jail}, a +@code{fail2ban-jail-configuration} object. + +For example: + +@lisp +(append + (list + (service + ;; The 'fail2ban-jail-service' procedure can extend any service type + ;; with a fail2ban jail. This removes the requirement to explicitly + ;; extend services with fail2ban-service-type. + (fail2ban-jail-service + openssh-service-type + (fail2ban-jail-configuration + (name "sshd") + (enabled #t))) + (openssh-configuration ...)))) +@end lisp +@end deffn + +Below is the reference for the different @code{jail-service-type} +configuration records. + +@c The documentation is to be auto-generated via +@c 'generate-documentation'. See at the bottom of (gnu services +@c security). + +@deftp {Data Type} fail2ban-configuration +Available @code{fail2ban-configuration} fields are: + +@table @asis +@item @code{fail2ban} (default: @code{fail2ban}) (type: package) +The @code{fail2ban} package to use. It is used for both binaries and as +base default configuration that is to be extended with +@code{} objects. + +@item @code{run-directory} (default: @code{"/var/run/fail2ban"}) (type: string) +The state directory for the @code{fail2ban} daemon. + +@item @code{jails} (default: @code{()}) (type: list-of-fail2ban-jail-configurations) +Instances of @code{} collected from +extensions. + +@item @code{extra-jails} (default: @code{()}) (type: list-of-fail2ban-jail-configurations) +Instances of @code{} explicitly provided. + +@item @code{extra-content} (type: maybe-string) +Extra raw content to add to the end of the @file{jail.local} file. + +@end table + +@end deftp + +@deftp {Data Type} fail2ban-ignore-cache-configuration +Available @code{fail2ban-ignore-cache-configuration} fields are: + +@table @asis +@item @code{key} (type: string) +Cache key. + +@item @code{max-count} (type: integer) +Cache size. + +@item @code{max-time} (type: integer) +Cache time. + +@end table + +@end deftp + +@deftp {Data Type} fail2ban-jail-action-configuration +Available @code{fail2ban-jail-action-configuration} fields are: + +@table @asis +@item @code{name} (type: string) +Action name. + +@item @code{arguments} (default: @code{()}) (type: list-of-arguments) +Action arguments. + +@end table + +@end deftp + +@deftp {Data Type} fail2ban-jail-configuration +Available @code{fail2ban-jail-configuration} fields are: + +@table @asis +@item @code{name} (type: string) +Required name of this jail configuration. + +@item @code{enabled?} (default: @code{#t}) (type: boolean) +Whether this jail is enabled. + +@item @code{backend} (type: maybe-symbol) +Backend to use to detect changes in the @code{ogpath}. The default is +'auto. To consult the defaults of the jail configuration, refer to the +@file{/etc/fail2ban/jail.conf} file of the @code{fail2ban} package. + +@item @code{max-retry} (type: maybe-integer) +The number of failures before a host get banned (e.g. @code{(max-retry +5)}). + +@item @code{max-matches} (type: maybe-integer) +The number of matches stored in ticket (resolvable via tag +@code{}) in action. + +@item @code{find-time} (type: maybe-string) +The time window during which the maximum retry count must be reached for +an IP address to be banned. A host is banned if it has generated +@code{max-retry} during the last @code{find-time} seconds (e.g. +@code{(find-time "10m")}). It can be provided in seconds or using +Fail2Ban's "time abbreviation format", as described in @command{man 5 +jail.conf}. + +@item @code{ban-time} (type: maybe-string) +The duration, in seconds or time abbreviated format, that a ban should +last. (e.g. @code{(ban-time "10m")}). + +@item @code{ban-time-increment?} (type: maybe-boolean) +Whether to consider past bans to compute increases to the default ban +time of a specific IP address. + +@item @code{ban-time-factor} (type: maybe-string) +The coefficient to use to compute an exponentially growing ban time. + +@item @code{ban-time-formula} (type: maybe-string) +This is the formula used to calculate the next value of a ban time. + +@item @code{ban-time-multipliers} (type: maybe-string) +Used to calculate next value of ban time instead of formula. + +@item @code{ban-time-max-time} (type: maybe-string) +The maximum number of seconds a ban should last. + +@item @code{ban-time-rnd-time} (type: maybe-string) +The maximum number of seconds a randomized ban time should last. This +can be useful to stop ``clever'' botnets calculating the exact time an +IP address can be unbanned again. + +@item @code{ban-time-overall-jails?} (type: maybe-boolean) +When true, it specifies the search of an IP address in the database +should be made across all jails. Otherwise, only the current jail of +the ban IP address is considered. + +@item @code{ignore-self?} (type: maybe-boolean) +Never ban the local machine's own IP address. + +@item @code{ignore-ip} (default: @code{()}) (type: list-of-strings) +A list of IP addresses, CIDR masks or DNS hosts to ignore. +@code{fail2ban} will not ban a host which matches an address in this +list. + +@item @code{ignore-cache} (type: maybe-fail2ban-ignore-cache-configuration) +Provide cache parameters for the ignore failure check. + +@item @code{filter} (type: maybe-fail2ban-jail-filter-configuration) +The filter to use by the jail, specified via a +@code{} object. By default, jails +have names matching their filter name. + +@item @code{log-time-zone} (type: maybe-string) +The default time zone for log lines that do not have one. + +@item @code{log-encoding} (type: maybe-symbol) +The encoding of the log files handled by the jail. Possible values are: +@code{'ascii}, @code{'utf-8} and @code{'auto}. + +@item @code{log-path} (default: @code{()}) (type: list-of-strings) +The file names of the log files to be monitored. + +@item @code{action} (default: @code{()}) (type: list-of-fail2ban-jail-actions) +A list of @code{}. + +@item @code{extra-content} (type: maybe-string) +Extra content for the jail configuration. + +@end table + +@end deftp + +@deftp {Data Type} fail2ban-jail-filter-configuration +Available @code{fail2ban-jail-filter-configuration} fields are: + +@table @asis +@item @code{name} (type: string) +Filter to use. + +@item @code{mode} (type: maybe-string) +Mode for filter. + +@end table + +@end deftp + +@c End of auto-generated fail2ban documentation. + @node Setuid Programs @section Setuid Programs -- cgit 1.4.1 From 0ea62e84a787fe94cfeadf67ef27ea995a382b84 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 3 Aug 2022 23:41:35 -0400 Subject: services: Add lightdm-service-type. * gnu/services/lightdm.scm: New service. * tests/services/lightdm.scm: Test it. * doc/guix.texi (X Window): Document it. * gnu/local.mk (GNU_SYSTEM_MODULES): Register it. Co-authored-by: L p R n d n Co-authored-by: Ricardo Wurmus --- Makefile.am | 1 + doc/guix.texi | 202 +++++++++++++ gnu/local.mk | 1 + gnu/services/lightdm.scm | 687 +++++++++++++++++++++++++++++++++++++++++++++ gnu/tests/lightdm.scm | 160 +++++++++++ tests/services/lightdm.scm | 52 ++++ 6 files changed, 1103 insertions(+) create mode 100644 gnu/services/lightdm.scm create mode 100644 gnu/tests/lightdm.scm create mode 100644 tests/services/lightdm.scm (limited to 'doc') diff --git a/Makefile.am b/Makefile.am index 8df8222573..502ca73866 100644 --- a/Makefile.am +++ b/Makefile.am @@ -533,6 +533,7 @@ SCM_TESTS = \ tests/services.scm \ tests/services/file-sharing.scm \ tests/services/configuration.scm \ + tests/services/lightdm.scm \ tests/services/linux.scm \ tests/services/telephony.scm \ tests/sets.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 4f6973518f..7199ff6bc2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -21278,6 +21278,208 @@ Relogin after logout. @end table @end deftp +@cindex lightdm, graphical login manager +@cindex display manager, lightdm +@defvr {Scheme Variable} lightdm-service-type +This is the type of the service to run the +@url{https://github.com/canonical/lightdm,LightDM display manager}. Its +value must be a @code{lightdm-configuration} record, which is documented +below. Among its distinguishing features are TigerVNC integration for +easily remoting your desktop as well as support for the XDMCP protocol, +which can be used by remote clients to start a session from the login +manager. + +In its most basic form, it can be used simply as: + +@lisp +(service lightdm-service-type) +@end lisp + +A more elaborate example making use of the VNC capabilities and enabling +more features and verbose logs could look like: + +@lisp +(service lightdm-service-type + (lightdm-configuration + (allow-empty-passwords? #t) + (xdmcp? #t) + (vnc-server? #t) + (vnc-server-command + (file-append tigervnc-server "/bin/Xvnc" + " -SecurityTypes None")) + (seats + (list (lightdm-seat-configuration + (name "*") + (user-session "ratpoison")))))) +@end lisp +@end defvr + +@c The LightDM service documentation can be auto-generated via the +@c 'generate-doc' procedure at the bottom of the (gnu services lightdm) +@c module. +@c %start of fragment +@deftp {Data Type} lightdm-configuration +Available @code{lightdm-configuration} fields are: + +@table @asis +@item @code{lightdm} (default: @code{lightdm}) (type: file-like) +The lightdm package to use. + +@item @code{allow-empty-passwords?} (default: @code{#f}) (type: boolean) +Whether users not having a password set can login. + +@item @code{debug?} (default: @code{#f}) (type: boolean) +Enable verbose output. + +@item @code{xorg-configuration} (type: xorg-configuration) +The default Xorg server configuration to use to generate the Xorg server +start script. It can be refined per seat via the @code{xserver-command} +of the @code{} record, if desired. + +@item @code{greeters} (type: list-of-greeter-configurations) +The LightDM greeter configurations specifying the greeters to use. + +@item @code{seats} (type: list-of-seat-configurations) +The seat configurations to use. A LightDM seat is akin to a user. + +@item @code{xdmcp?} (default: @code{#f}) (type: boolean) +Whether a XDMCP server should listen on port UDP 177. + +@item @code{xdmcp-listen-address} (type: maybe-string) +The host or IP address the XDMCP server listens for incoming +connections. When unspecified, listen on for any hosts/IP addresses. + +@item @code{vnc-server?} (default: @code{#f}) (type: boolean) +Whether a VNC server is started. + +@item @code{vnc-server-command} (type: file-like) +The Xvnc command to use for the VNC server, it's possible to provide +extra options not otherwise exposed along the command, for example to +disable security: + +@lisp +(vnc-server-command (file-append tigervnc-server "/bin/Xvnc" + " -SecurityTypes None" )) +@end lisp + +Or to set a PasswordFile for the classic (unsecure) VncAuth +mecanism: + +@lisp +(vnc-server-command (file-append tigervnc-server "/bin/Xvnc" + " -PasswordFile /var/lib/lightdm/.vnc/passwd")) +@end lisp + +The password file should be manually created using the +@command{vncpasswd} command. Note that LightDM will create new sessions +for VNC users, which means they need to authenticate in the same way as +local users would. + +@item @code{vnc-server-listen-address} (type: maybe-string) +The host or IP address the VNC server listens for incoming connections. +When unspecified, listen for any hosts/IP addresses. + +@item @code{vnc-server-port} (default: @code{5900}) (type: number) +The TCP port the VNC server should listen to. + +@item @code{extra-config} (default: @code{()}) (type: list-of-strings) +Extra configuration values to append to the LightDM configuration file. + +@end table +@end deftp + + +@c %end of fragment +@c %start of fragment + +@deftp {Data Type} lightdm-gtk-greeter-configuration +Available @code{lightdm-gtk-greeter-configuration} fields are: + +@table @asis +@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) +The list of packages complementing the greeter, such as package +providing icon themes. + +@item @code{theme-name} (default: @code{"Adwaita"}) (type: string) +The name of the theme to use. + +@item @code{icon-theme-name} (default: @code{"Adwaita"}) (type: string) +The name of the icon theme to use. + +@item @code{cursor-theme-name} (default: @code{"Adwaita"}) (type: string) +The name of the cursor theme to use. + +@item @code{cursor-theme-size} (default: @code{16}) (type: number) +The size to use for the the cursor theme. + +@item @code{allow-debugging?} (type: maybe-boolean) +Set to #t to enable debug log level. + +@item @code{background} (type: file-like) +The background image to use. + +@item @code{at-spi-enabled?} (default: @code{#f}) (type: boolean) +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) +The accessibility features to enable, given as list of symbols. + +@item @code{reader} (type: maybe-file-like) +The command to use to launch a screen reader. + +@item @code{extra-config} (default: @code{()}) (type: list-of-strings) +Extra configuration values to append to the LightDM GTK Greeter +configuration file. + +@end table +@end deftp + +@c %end of fragment +@c %start of fragment + +@deftp {Data Type} lightdm-seat-configuration +Available @code{lightdm-seat-configuration} fields are: + +@table @asis +@item @code{name} (type: seat-name) +The name of the seat. An asterisk (*) can be used in the name to apply +the seat configuration to all the seat names it matches. + +@item @code{user-session} (type: maybe-string) +The session to use by default. The session name must be provided as a +lowercase string, such as @code{"gnome"}, @code{"ratpoison"}, etc. + +@item @code{type} (default: @code{local}) (type: seat-type) +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) +The greeter session to use, specified as a symbol. Currently, only +@code{lightdm-gtk-greeter} is supported. + +@item @code{xserver-command} (type: maybe-file-like) +The Xorg server command to run. + +@item @code{session-wrapper} (type: file-like) +The xinitrc session wrapper to use. + +@item @code{extra-config} (default: @code{()}) (type: list-of-strings) +Extra configuration values to append to the seat configuration section. + +@end table +@end deftp +@c %end of fragment + @cindex Xorg, configuration @deftp {Data Type} xorg-configuration diff --git a/gnu/local.mk b/gnu/local.mk index a9aebe5193..b67dfac4e7 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -661,6 +661,7 @@ GNU_SYSTEM_MODULES = \ %D%/services/guix.scm \ %D%/services/hurd.scm \ %D%/services/kerberos.scm \ + %D%/services/lightdm.scm \ %D%/services/linux.scm \ %D%/services/lirc.scm \ %D%/services/virtualization.scm \ diff --git a/gnu/services/lightdm.scm b/gnu/services/lightdm.scm new file mode 100644 index 0000000000..07f2e808dd --- /dev/null +++ b/gnu/services/lightdm.scm @@ -0,0 +1,687 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 L p R n d n +;;; Copyright © 2020 Ricardo Wurmus +;;; Copyright © 2022 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 (gnu services lightdm) + #:use-module (gnu artwork) + #:use-module (gnu packages admin) + #:use-module (gnu packages display-managers) + #:use-module (gnu packages freedesktop) + #:use-module (gnu packages gnome) + #:use-module (gnu packages vnc) + #:use-module (gnu packages xorg) + #:use-module (gnu services configuration) + #:use-module (gnu services dbus) + #:use-module (gnu services desktop) + #:use-module (gnu services shepherd) + #:use-module (gnu services xorg) + #:use-module (gnu services) + #:use-module (gnu system pam) + #:use-module (gnu system shadow) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix i18n) + #:use-module (guix records) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (lightdm-seat-configuration + lightdm-seat-configuration? + lightdm-seat-configuration-name + lightdm-seat-configuration-type + lightdm-seat-configuration-user-session + lightdm-seat-configuration-autologin-user + lightdm-seat-configuration-greeter-session + lightdm-seat-configuration-xserver-command + lightdm-seat-configuration-session-wrapper + lightdm-seat-configuration-extra-config + + lightdm-gtk-greeter-configuration + lightdm-gtk-greeter-configuration? + lightdm-gtk-greeter-configuration-lightdm-gtk-greeter + lightdm-gtk-greeter-configuration-assets + lightdm-gtk-greeter-configuration-theme-name + lightdm-gtk-greeter-configuration-icon-theme-name + lightdm-gtk-greeter-configuration-cursor-theme-name + lightdm-gtk-greeter-configuration-allow-debug + lightdm-gtk-greeter-configuration-background + lightdm-gtk-greeter-configuration-a11y-states + lightdm-gtk-greeter-configuration-reader + lightdm-gtk-greeter-configuration-extra-config + + lightdm-configuration + lightdm-configuration? + lightdm-configuration-lightdm + lightdm-configuration-allow-empty-passwords? + lightdm-configuration-xorg-configuration + lightdm-configuration-greeters + lightdm-configuration-seats + lightdm-configuration-xdmcp? + lightdm-configuration-xdmcp-listen-address + lightdm-configuration-vnc-server? + lightdm-configuration-vnc-server-command + lightdm-configuration-vnc-server-listen-address + lightdm-configuration-vnc-server-port + lightdm-configuration-extra-config + + lightdm-service-type)) + +;;; +;;; Greeters. +;;; + +(define list-of-file-likes? + (list-of file-like?)) + +(define %a11y-states '(contrast font keyboard reader)) + +(define (a11y-state? value) + (memq value %a11y-states)) + +(define list-of-a11y-states? + (list-of a11y-state?)) + +(define-maybe boolean) + +(define (serialize-boolean name value) + (define (strip-trailing-? name) + ;; field? -> field + (let ((str (symbol->string name))) + (if (string-suffix? "?" str) + (string-drop-right str 1) + str))) + (format #f "~a=~:[false~;true~]~%" (strip-trailing-? name) value)) + +(define-maybe file-like) + +(define (serialize-file-like name value) + #~(format #f "~a=~a~%" '#$name #$value)) + +(define (serialize-list-of-a11y-states name value) + (format #f "~a=~a~%" name (string-join (map symbol->string value) ";"))) + +(define (serialize-string name value) + (format #f "~a=~a~%" name value)) + +(define (serialize-number name value) + (format #f "~a=~a~%" name value)) + +(define (serialize-list-of-strings _ value) + (string-join value "\n")) + +(define-configuration lightdm-gtk-greeter-configuration + (lightdm-gtk-greeter + (file-like lightdm-gtk-greeter) + "The lightdm-gtk-greeter package to use." + empty-serializer) + (assets + (list-of-file-likes (list adwaita-icon-theme + gnome-themes-extra + ;; FIXME: hicolor-icon-theme should be in the + ;; packages of the desktop templates. + hicolor-icon-theme)) + "The list of packages complementing the greeter, such as package providing +icon themes." + empty-serializer) + (theme-name + (string "Adwaita") + "The name of the theme to use.") + (icon-theme-name + (string "Adwaita") + "The name of the icon theme to use.") + (cursor-theme-name + (string "Adwaita") + "The name of the cursor theme to use.") + (cursor-theme-size + (number 16) + "The size to use for the the cursor theme.") + (allow-debugging? + maybe-boolean + "Set to #t to enable debug log level.") + (background + (file-like (file-append %artwork-repository + "/backgrounds/guix-checkered-16-9.svg")) + "The background image to use.") + ;; FIXME: This should be enabled by default, but it currently doesn't work, + ;; failing to connect to D-Bus, causing the login to fail. + (at-spi-enabled? + (boolean #f) + "Enable accessibility support through the Assistive Technology Service +Provider Interface (AT-SPI).") + (a11y-states + (list-of-a11y-states %a11y-states) + "The accessibility features to enable, given as list of symbols.") + (reader + maybe-file-like + "The command to use to launch a screen reader.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the LightDM GTK Greeter +configuration file.")) + +(define (strip-class-name-brackets name) + "Remove the '<<' and '>>' brackets from NAME, a symbol." + (let ((name* (symbol->string name))) + (if (and (string-prefix? "<<" name*) + (string-suffix? ">>" name*)) + (string->symbol (string-drop (string-drop-right name* 2) 2)) + (error "unexpected class name" name*)))) + +(define (config->name config) + "Return the constructor name (a symbol) from CONFIG." + (strip-class-name-brackets (class-name (class-of config)))) + +(define (greeter-configuration->greeter-fields config) + "Return the fields of CONFIG, a greeter configuration." + (match config + ;; Note: register any new greeter configuration here. + ((? lightdm-gtk-greeter-configuration?) + lightdm-gtk-greeter-configuration-fields))) + +(define (greeter-configuration->packages config) + "Return the list of greeter packages, including assets, used by CONFIG, a +greeter configuration." + (match config + ;; Note: register any new greeter configuration here. + ((? lightdm-gtk-greeter-configuration?) + (cons (lightdm-gtk-greeter-configuration-lightdm-gtk-greeter config) + (lightdm-gtk-greeter-configuration-assets config))))) + +;;; TODO: Implement directly in (gnu services configuration), perhaps by +;;; making the FIELDS argument optional. +(define (serialize-configuration* config) + "Like `serialize-configuration', but not requiring to provide a FIELDS +argument." + (define fields (greeter-configuration->greeter-fields config)) + (serialize-configuration config fields)) + +(define (greeter-configuration->conf-name config) + "Return the file name of CONFIG, a greeter configuration." + (format #f "~a.conf" (greeter-configuration->greeter-session config))) + +(define (greeter-configuration->file config) + "Serialize CONFIG into a file under the output directory, so that it can be +easily added to XDG_CONF_DIRS." + (computed-file + (greeter-configuration->conf-name config) + #~(begin + (call-with-output-file #$output + (lambda (port) + (format port (string-append + "[greeter]\n" + #$(serialize-configuration* config)))))))) + + +;;; +;;; Seats. +;;; + +(define seat-name? string?) + +(define (serialize-seat-name _ value) + (format #f "[Seat:~a]~%" value)) + +(define (seat-type? type) + (memq type '(local xremote))) + +(define (serialize-seat-type name value) + (format #f "~a=~a~%" name value)) + +(define-maybe seat-type) + +(define (greeter-session? value) + (memq value '(lightdm-gtk-greeter))) + +(define (serialize-greeter-session name value) + (format #f "~a=~a~%" name value)) + +(define-maybe greeter-session) + +(define-maybe string) + +;;; Note: all the fields except for the seat name should be 'maybe's, since +;;; the real default value is set by the %lightdm-seat-default define later, +;;; and this avoids repeating ourselves in the serialized configuration file. +(define-configuration lightdm-seat-configuration + (name + seat-name + "The name of the seat. An asterisk (*) can be used in the name +to apply the seat configuration to all the seat names it matches.") + (user-session + maybe-string + "The session to use by default. The session name must be provided as a +lowercase string, such as @code{\"gnome\"}, @code{\"ratpoison\"}, etc.") + (type + (seat-type 'local) + "The type of the seat, either the @code{local} or @code{xremote} symbol.") + (autologin-user + maybe-string + "The username to automatically log in with by default.") + (greeter-session + (greeter-session 'lightdm-gtk-greeter) + "The greeter session to use, specified as a symbol. Currently, only +@code{lightdm-gtk-greeter} is supported.") + ;; Note: xserver-command must be lazily computed, so that it can be + ;; overridden via 'lightdm-configuration-xorg-configuration'. + (xserver-command + maybe-file-like + "The Xorg server command to run.") + (session-wrapper + (file-like (xinitrc)) + "The xinitrc session wrapper to use.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the seat configuration section.")) + +(define (greeter-session->greater-configuration-pred identifier) + "Return the predicate to check if a configuration is of the type specifying +a greeter identified by IDENTIFIER." + (match identifier + ;; Note: register any new greeter identifier here. + ('lightdm-gtk-greeter + lightdm-gtk-greeter-configuration?))) + +(define (greeter-configuration->greeter-session config) + "Given CONFIG, a greeter configuration object, return its identifier, +a symbol." + (let ((suffix "-configuration") + (greeter-conf-name (config->name config))) + (string->symbol (string-drop-right (symbol->string greeter-conf-name) + (string-length suffix))))) + +(define list-of-seat-configurations? + (list-of lightdm-seat-configuration?)) + + +;;; +;;; LightDM. +;;; + +(define (greeter-configuration? config) + (or (lightdm-gtk-greeter-configuration? config) + ;; Note: register any new greeter configuration here. + )) + +(define (list-of-greeter-configurations? greeter-configs) + (and ((list-of greeter-configuration?) greeter-configs) + ;; Greeter configurations must also not be provided more than once. + (let* ((types (map (cut (compose class-name class-of) <>) + greeter-configs)) + (dupes (filter (lambda (type) + (< 1 (count (cut eq? type <>) types))) + types))) + (unless (null? dupes) + (leave (G_ "duplicate greeter configurations: ~a~%") dupes))))) + +(define-configuration/no-serialization lightdm-configuration + (lightdm + (file-like lightdm) + "The lightdm package to use.") + (allow-empty-passwords? + (boolean #f) + "Whether users not having a password set can login.") + (debug? + (boolean #f) + "Enable verbose output.") + (xorg-configuration + (xorg-configuration (xorg-configuration)) + "The default Xorg server configuration to use to generate the Xorg server +start script. It can be refined per seat via the @code{xserver-command} of +the @code{} record, if desired.") + (greeters + (list-of-greeter-configurations (list (lightdm-gtk-greeter-configuration))) + "The LightDM greeter configurations specifying the greeters to use.") + (seats + (list-of-seat-configurations (list (lightdm-seat-configuration + (name "*")))) + "The seat configurations to use. A LightDM seat is akin to a user.") + (xdmcp? + (boolean #f) + "Whether a XDMCP server should listen on port UDP 177.") + (xdmcp-listen-address + maybe-string + "The host or IP address the XDMCP server listens for incoming connections. +When unspecified, listen on for any hosts/IP addresses.") + (vnc-server? + (boolean #f) + "Whether a VNC server is started.") + (vnc-server-command + (file-like (file-append tigervnc-server "bin/Xvnc")) + "The Xvnc command to use for the VNC server, it's possible to provide extra +options not otherwise exposed along the command, for example to disable +security: +@lisp +(vnc-server-command + (file-append tigervnc-server \"/bin/Xvnc\" + \" -SecurityTypes None\" )) +@end lisp + +Or to set a PasswordFile for the classic (unsecure) VncAuth mecanism: +@lisp +(vnc-server-command + (file-append tigervnc-server \"/bin/Xvnc\" + \" -PasswordFile /var/lib/lightdm/.vnc/passwd\")) +@end lisp +The password file should be manually created using the @command{vncpasswd} +command. + +Note that LightDM will create new sessions for VNC users, which means they +need to authenticate in the same way as local users would. +") + (vnc-server-listen-address + maybe-string + "The host or IP address the VNC server listens for incoming connections. +When unspecified, listen for any hosts/IP addresses.") + (vnc-server-port + (number 5900) + "The TCP port the VNC server should listen to.") + (extra-config + (list-of-strings '()) + "Extra configuration values to append to the LightDM configuration file.")) + +(define (lightdm-configuration->greeters-config-dir config) + "Return a directory containing all the serialized greeter configurations +from CONFIG, a object." + (file-union "etc-lightdm" + (append-map (lambda (g) + `((,(greeter-configuration->conf-name g) + ,(greeter-configuration->file g)))) + (lightdm-configuration-greeters config)))) + +(define (lightdm-configuration->packages config) + "Return all the greeter packages and their assets defined in CONFIG, a + object, as well as the lightdm package itself." + (cons (lightdm-configuration-lightdm config) + (append-map greeter-configuration->packages + (lightdm-configuration-greeters config)))) + +(define (validate-lightdm-configuration config) + "Sanity check CONFIG, a record instance." + ;; This is required to make inter-field validations, such as between the + ;; seats and greeters. + (let* ((seats (lightdm-configuration-seats config)) + (greeter-sessions (delete-duplicates + (map lightdm-seat-configuration-greeter-session + seats) + eq?)) + (greeter-configurations (lightdm-configuration-greeters config)) + (missing-greeters + (filter-map + (lambda (id) + (define pred (greeter-session->greater-configuration-pred id)) + (if (find pred greeter-configurations) + #f ;happy path + id)) + greeter-sessions))) + (unless (null? missing-greeters) + (leave (G_ "no greeter configured for seat greeter sessions: ~a~%") + missing-greeters)))) + +(define (lightdm-configuration-file config) + (match-record config + (xorg-configuration seats + xdmcp? xdmcp-listen-address + vnc-server? vnc-server-command vnc-server-listen-address vnc-server-port + extra-config) + (apply + mixed-text-file + "lightdm.conf" " +# +# General configuration +# +[LightDM] +greeter-user=lightdm +sessions-directory=/run/current-system/profile/share/xsessions\ +:/run/current-system/profile/share/wayland-sessions +remote-sessions-directory=/run/current-system/profile/share/remote-sessions +" + #~(string-join '#$extra-config "\n") + " +# +# XDMCP Server configuration +# +[XDMCPServer] +enabled=" (if xdmcp? "true" "false") "\n" +(if (maybe-value-set? xdmcp-listen-address) + (format #f "xdmcp-listen-address=~a" xdmcp-listen-address) + "") " + +# +# VNC Server configuration +# +[VNCServer] +enabled=" (if vnc-server? "true" "false") " +command=" vnc-server-command " +port=" (number->string vnc-server-port) "\n" +(if (maybe-value-set? vnc-server-listen-address) + (format #f "vnc-server-listen-address=~a" vnc-server-listen-address) + "") " + +# +# Seat configuration. +# +" + (map (lambda (seat) + ;; This complication exists to propagate a default value for + ;; the 'xserver-command' field of the seats. Having a + ;; 'xorg-configuration' field at the root of the + ;; lightdm-configuration enables the use of + ;; 'set-xorg-configuration' and can be more convenient. + (let ((seat* (if (maybe-value-set? + (lightdm-seat-configuration-xserver-command seat)) + seat + (lightdm-seat-configuration + (inherit seat) + (xserver-command (xorg-start-command + xorg-configuration)))))) + (serialize-configuration seat* + lightdm-seat-configuration-fields))) + seats)))) + +(define %lightdm-accounts + (list (user-group (name "lightdm") (system? #t)) + (user-account + (name "lightdm") + (group "lightdm") + (system? #t) + (comment "LightDM user") + (home-directory "/var/lib/lightdm") + (shell (file-append shadow "/sbin/nologin"))))) + +(define %lightdm-activation + ;; Ensure /var/lib/lightdm is owned by the "lightdm" user. Adapted from the + ;; %gdm-activation. + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define (ensure-ownership directory) + (let* ((lightdm (getpwnam "lightdm")) + (uid (passwd:uid lightdm)) + (gid (passwd:gid lightdm)) + (st (stat directory #f))) + ;; Recurse into directory only if it has wrong ownership. + (when (and st + (or (not (= uid (stat:uid st))) + (not (= gid (stat:gid st))))) + (for-each (lambda (file) + (chown file uid gid)) + (find-files "directory" + #:directories? #t))))) + + (when (not (stat "/var/lib/lightdm-data" #f)) + (mkdir-p "/var/lib/lightdm-data")) + (for-each ensure-ownership + '("/var/lib/lightdm" + "/var/lib/lightdm-data"))))) + +(define (lightdm-pam-service config) + "Return a PAM service for @command{lightdm}." + (unix-pam-service "lightdm" + #:login-uid? #t + #:allow-empty-passwords? + (lightdm-configuration-allow-empty-passwords? config))) + +(define (lightdm-greeter-pam-service) + "Return a PAM service for @command{lightdm-greeter}." + (pam-service + (name "lightdm-greeter") + (auth (list + ;; Load environment from /etc/environment and ~/.pam_environment. + (pam-entry (control "required") (module "pam_env.so")) + ;; Always let the greeter start without authentication. + (pam-entry (control "required") (module "pam_permit.so")))) + ;; No action required for account management + (account (list (pam-entry (control "required") (module "pam_permit.so")))) + ;; Prohibit changing password. + (password (list (pam-entry (control "required") (module "pam_deny.so")))) + ;; Setup session. + (session (list (pam-entry (control "required") (module "pam_unix.so")))))) + +(define (lightdm-autologin-pam-service) + "Return a PAM service for @command{lightdm-autologin}}." + (pam-service + (name "lightdm-autologin") + (auth + (list + ;; Block login if user is globally disabled. + (pam-entry (control "required") (module "pam_nologin.so")) + (pam-entry (control "required") (module "pam_succeed_if.so") + (arguments (list "uid >= 1000"))) + ;; Allow access without authentication. + (pam-entry (control "required") (module "pam_permit.so")))) + ;; Stop autologin if account requires action. + (account (list (pam-entry (control "required") (module "pam_unix.so")))) + ;; Prohibit changing password. + (password (list (pam-entry (control "required") (module "pam_deny.so")))) + ;; Setup session. + (session (list (pam-entry (control "required") (module "pam_unix.so")))))) + +(define (lightdm-pam-services config) + (list (lightdm-pam-service config) + (lightdm-greeter-pam-service) + (lightdm-autologin-pam-service))) + +(define (lightdm-shepherd-service config) + "Return a for LightDM using CONFIG." + + (validate-lightdm-configuration config) + + (define lightdm-command + #~(list #$(file-append (lightdm-configuration-lightdm config) + "/sbin/lightdm") + #$@(if (lightdm-configuration-debug? config) + #~("--debug") + #~()) + "--config" + #$(lightdm-configuration-file config))) + + (define lightdm-paths + (let ((lightdm (lightdm-configuration-lightdm config))) + #~(string-join + '#$(map (lambda (dir) + (file-append lightdm dir)) + '("/bin" "/sbin" "/libexec")) + ":"))) + + (define greeters-config-dir + (lightdm-configuration->greeters-config-dir config)) + + (define data-dirs + ;; LightDM itself needs to be in XDG_DATA_DIRS for the accountsservice + ;; interface it provides to be picked up. The greeters must also be in + ;; XDG_DATA_DIRS to be found. + (let ((packages (lightdm-configuration->packages config))) + #~(string-join '#$(map (cut file-append <> "/share") packages) + ":"))) + + (list + (shepherd-service + (documentation "LightDM display manager") + (requirement '(dbus-system user-processes host-name)) + (provision '(lightdm display-manager xorg-server)) + (respawn? #f) + (start + #~(lambda () + ;; Note: sadly, environment variables defined for 'lightdm' are + ;; cleared and/or overridden by /etc/profile by its spawned greeters, + ;; so an out-of-band means such as /etc is required. + (fork+exec-command #$lightdm-command + ;; Lightdm needs itself in its PATH. + #:environment-variables + (list + ;; It knows to look for greeter configurations in + ;; XDG_CONFIG_DIRS... + (string-append "XDG_CONFIG_DIRS=" + #$greeters-config-dir) + ;; ... and for greeter .desktop files as well as + ;; lightdm accountsservice interface in + ;; XDG_DATA_DIRS. + (string-append "XDG_DATA_DIRS=" + #$data-dirs) + (string-append "PATH=" #$lightdm-paths))))) + (stop #~(make-kill-destructor))))) + +(define lightdm-service-type + (handle-xorg-configuration + lightdm-configuration + (service-type + (name 'lightdm) + (default-value (lightdm-configuration)) + (extensions + (list (service-extension pam-root-service-type lightdm-pam-services) + (service-extension shepherd-root-service-type + lightdm-shepherd-service) + (service-extension activation-service-type + (const %lightdm-activation)) + (service-extension dbus-root-service-type + (compose list lightdm-configuration-lightdm)) + (service-extension polkit-service-type + (compose list lightdm-configuration-lightdm)) + (service-extension account-service-type + (const %lightdm-accounts)) + ;; Add 'lightdm' to the system profile, so that its + ;; 'share/accountsservice' D-Bus service extension directory can be + ;; found via the 'XDG_DATA_DIRS=/run/current-system/profile/share' + ;; environment variable set in the wrapper of the + ;; libexec/accounts-daemon binary of the accountsservice package. + ;; This daemon is spawned by D-Bus, and there's little we can do to + ;; affect its environment. For more reading, see: + ;; https://github.com/NixOS/nixpkgs/issues/45059. + (service-extension profile-service-type + lightdm-configuration->packages) + ;; This is needed for the greeter itself to find its configuration, + ;; because XDG_CONF_DIRS gets overridden by /etc/profile. + (service-extension + etc-service-type + (lambda (config) + `(("lightdm" + ,(lightdm-configuration->greeters-config-dir config))))))) + (description "Run @code{lightdm}, the LightDM graphical login manager.")))) + + +;;; +;;; Generate documentation. +;;; +(define (generate-doc) + (configuration->documentation 'lightdm-configuration) + (configuration->documentation 'lightdm-gtk-greeter-configuration) + (configuration->documentation 'lightdm-seat-configuration)) diff --git a/gnu/tests/lightdm.scm b/gnu/tests/lightdm.scm new file mode 100644 index 0000000000..431b388e7e --- /dev/null +++ b/gnu/tests/lightdm.scm @@ -0,0 +1,160 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 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 (gnu tests lightdm) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu packages) + #:use-module (gnu packages ocr) + #:use-module (gnu packages ratpoison) + #:use-module (gnu packages vnc) + #:use-module (gnu packages xorg) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services dbus) + #:use-module (gnu services desktop) + #:use-module (gnu services networking) + #:use-module (gnu services lightdm) + #:use-module (gnu services ssh) + #:use-module (gnu services xorg) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu tests) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (srfi srfi-1) + #:export (%test-lightdm)) + +(define minimal-desktop-services + (list polkit-wheel-service + (service upower-service-type) + (accountsservice-service) + (service polkit-service-type) + (elogind-service) + (dbus-service) + x11-socket-directory-service)) + +(define %lightdm-os + (operating-system + (inherit %simple-os) + (packages (cons* ocrad ratpoison xterm %base-packages)) + (services + (cons* (service lightdm-service-type + (lightdm-configuration + (allow-empty-passwords? #t) + (debug? #t) + (xdmcp? #t) + (vnc-server? #t) + (vnc-server-command + (file-append tigervnc-server "/bin/Xvnc" + " -SecurityTypes None")) + (greeters (list (lightdm-gtk-greeter-configuration + (allow-debugging? #t)))) + (seats (list (lightdm-seat-configuration + (name "*") + (user-session "ratpoison")))))) + + ;; For debugging. + (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t))) + (append minimal-desktop-services + (remove (lambda (service) + (eq? (service-kind service) guix-service-type)) + %base-services)))))) + +(define (run-lightdm-test) + "Run tests in %LIGHTDM-OS." + + (define os (marionette-operating-system + %lightdm-os + #:imported-modules (source-module-closure + '((gnu services herd))))) + + (define vm (virtual-machine os)) + + (define test + (with-imported-modules (source-module-closure + '((gnu build marionette))) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-26) + (srfi srfi-64)) + + (let ((marionette (make-marionette (list #$vm)))) + + (test-runner-current (system-test-runner #$output)) + (test-begin "lightdm") + + (test-assert "service is running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'lightdm)) + marionette)) + + (test-assert "service can be stopped" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (stop-service 'lightdm)) + marionette)) + + (test-assert "service can be restarted" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (restart-service 'lightdm)) + marionette)) + + (test-assert "login screen is displayed" + ;; GNU Ocrad fails to recognize the "Log In" button text, so use + ;; Tesseract. + (wait-for-screen-text marionette + (cut string-contains <> "Log In") + #:ocr #$(file-append tesseract-ocr + "/bin/tesseract"))) + + (test-assert "can connect to TCP port 5900 on IPv4" + (wait-for-tcp-port 5900 marionette)) + + ;; The VNC server fails to listen to IPv6 due to "Error binding to + ;; address [::]:5900: Address already in use" (see: + ;; https://github.com/canonical/lightdm/issues/266). + (test-expect-fail 1) + (test-assert "can connect to TCP port 5900 on IPv6" + (wait-for-tcp-port 5900 marionette + #:address + `(make-socket-address + AF_INET6 + (inet-pton AF_INET6 "::1") + 5900))) + + (test-end))))) + + (gexp->derivation "lightdm-test" test)) + +(define %test-lightdm + (system-test + (name "lightdm") + (description "Basic tests for the LightDM service.") + (value (run-lightdm-test)))) diff --git a/tests/services/lightdm.scm b/tests/services/lightdm.scm new file mode 100644 index 0000000000..283df2befc --- /dev/null +++ b/tests/services/lightdm.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 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 (tests services lightdm) + #:use-module (guix diagnostics) + #:use-module (gnu services lightdm) + #:use-module (srfi srfi-64)) + +;;; Tests for the (gnu services lightdm) module. + +;;; Access some internals for whitebox testing. +(define validate-lightdm-configuration (@@ (gnu services lightdm) + validate-lightdm-configuration)) + +(test-begin "lightdm-service") + +(test-equal "error on missing greeter" + 'ok + (catch 'quit + (lambda () + (validate-lightdm-configuration (lightdm-configuration (greeters '())))) + (lambda _ + 'ok))) + +(test-equal "error when a greeter has multiple configurations" + 'ok + (catch 'quit + (lambda () + (lightdm-configuration + (greeters (list (lightdm-gtk-greeter-configuration + (theme-name "boring")) + (lightdm-gtk-greeter-configuration + (theme-name "blue")))))) + (lambda _ + 'ok))) + +(test-end "lightdm-service") -- cgit 1.4.1 From f126f23b132148192b2c9a89032a5831af0b3c52 Mon Sep 17 00:00:00 2001 From: Reza Alizadeh Majd Date: Sun, 28 Aug 2022 12:34:46 +0430 Subject: bootloader: Add device-tree-support? option. In some specific cases where the device tree file is already loaded in RAM, it can be preferable that the bootloader does not try to use a device tree from the Linux kernel tree. * gnu/bootloader.scm ()[device-tree-support?]: New field. * gnu/bootloader/extlinux.scm (extlinux-configuration-file): Add FDTDIR line based on field of . * doc/guix.texi (Bootloader Configuration)[device-tree-support?]: Add documentation for the new field. --- doc/guix.texi | 9 +++++++++ gnu/bootloader.scm | 6 +++++- gnu/bootloader/extlinux.scm | 12 ++++++++++-- 3 files changed, 24 insertions(+), 3 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 7199ff6bc2..3c575dad11 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -37439,6 +37439,15 @@ corresponds to COM1 (@pxref{Serial terminal,,, grub,GNU GRUB manual}). The speed of the serial interface, as an integer. For GRUB, the default value is chosen at run-time; currently GRUB chooses 9600@tie{}bps (@pxref{Serial terminal,,, grub,GNU GRUB manual}). + +@item @code{device-tree-support?} (default: @code{#t}) +Whether to support Linux @uref{https://en.wikipedia.org/wiki/Devicetree, +device tree} files loading. + +This option in enabled by default. In some cases involving the +@code{u-boot} bootloader, where the device tree has already been loaded +in RAM, it can be handy to disable the option by setting it to +@code{#f}. @end table @end deftp diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 2eec48693c..7d076ec51c 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2019, 2021 Ludovic Courtès ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2022 Josselin Poiret +;;; Copyright © 2022 Reza Alizadeh Majd ;;; ;;; This file is part of GNU Guix. ;;; @@ -72,6 +73,7 @@ bootloader-configuration-terminal-inputs bootloader-configuration-serial-unit bootloader-configuration-serial-speed + bootloader-configuration-device-tree-support? %bootloaders lookup-bootloader-by-name @@ -232,7 +234,9 @@ instead~%"))) (serial-unit bootloader-configuration-serial-unit ;integer | #f (default #f)) (serial-speed bootloader-configuration-serial-speed ;integer | #f - (default #f))) + (default #f)) + (device-tree-support? bootloader-configuration-device-tree-support? + (default #t))) ;boolean (define-deprecated (bootloader-configuration-target config) bootloader-configuration-targets diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm index 6b5ff298e7..d9b6d8bf8a 100644 --- a/gnu/bootloader/extlinux.scm +++ b/gnu/bootloader/extlinux.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 David Craven ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2022 Reza Alizadeh Majd ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +39,9 @@ corresponding to old generations of the system." (define all-entries (append entries (bootloader-configuration-menu-entries config))) + (define with-fdtdir? + (bootloader-configuration-device-tree-support? config)) + (define (menu-entry->gexp entry) (let ((label (menu-entry-label entry)) (kernel (menu-entry-linux entry)) @@ -46,12 +50,16 @@ corresponding to old generations of the system." #~(format port "LABEL ~a MENU LABEL ~a KERNEL ~a - FDTDIR ~a/lib/dtbs + ~a INITRD ~a APPEND ~a ~%" #$label #$label - #$kernel (dirname #$kernel) #$initrd + #$kernel + (if #$with-fdtdir? + (string-append "FDTDIR " (dirname #$kernel) "/lib/dtbs") + "") + #$initrd (string-join (list #$@kernel-arguments))))) (define builder -- cgit 1.4.1 From 65ce5fe2fb1783c5eae7b439f79627fdb5e9c578 Mon Sep 17 00:00:00 2001 From: Thiago Jung Bauermann Date: Sun, 21 Aug 2022 03:11:24 -0300 Subject: guix system: Use standard cross and native build options. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change prevents guix system from erroring out with an ugly backtrace when it's passed an invalid value to the “--system” or “--target” option. It also adds the “--list-systems” and “--list-targets” options. The manual section about guix system doesn't mention the “--target” option, so add it there. * guix/scripts/system (show-help): Call show-cross-build-options-help and show-native-build-options-help. (%options): Remove own implementation of “system” and “target” options and use the ones in %standard-cross-build-options and %standard-native-build-options. * doc/guix.texi (Invoking guix system): Document “--target” option. Signed-off-by: Mathieu Othacehe --- doc/guix.texi | 5 +++++ guix/scripts/system.scm | 16 +++++++--------- 2 files changed, 12 insertions(+), 9 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 3c575dad11..957b9a668e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -38021,6 +38021,11 @@ Installation Image}). Attempt to build for @var{system} instead of the host system type. This works as per @command{guix build} (@pxref{Invoking guix build}). +@item --target=@var{triplet} +Cross-build for @var{triplet}, which must be a valid GNU triplet, such +as @code{"aarch64-linux-gnu"} (@pxref{Specifying target triplets, GNU +configuration triplets,, autoconf, Autoconf}). + @item --derivation @itemx -d Return the derivation file name of the given operating system without diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index be6e839941..443e9d3282 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1046,6 +1046,10 @@ Some ACTIONS support additional ARGS.\n")) for 'describe' and 'list-generations', list installed packages matching REGEXP")) (newline) + (show-cross-build-options-help) + (newline) + (show-native-build-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -1136,14 +1140,6 @@ Some ACTIONS support additional ARGS.\n")) (let ((level (string->number* arg))) (alist-cons 'verbosity level (alist-delete 'verbosity result))))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '("target") #t #f - (lambda (opt name arg result) - (alist-cons 'target arg - (alist-delete 'target result eq?)))) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -1153,7 +1149,9 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\I "list-installed") #f #t (lambda (opt name arg result) (alist-cons 'list-installed (or arg "") result))) - %standard-build-options)) + (append %standard-build-options + %standard-cross-build-options + %standard-native-build-options))) (define %default-options ;; Alist of default option values. -- cgit 1.4.1 From c4acaf412064568a546034871a9e0d3888aa7937 Mon Sep 17 00:00:00 2001 From: Nicolas Graves Date: Fri, 12 Aug 2022 10:58:48 +0200 Subject: etc: Add tempel snippets. * etc/snippets/tempel/scheme-mode: New file. * etc/snippets/tempel/text-mode: New file. * etc/snippets/scheme-mode: Moved from here... * etc/snippets/yas/scheme-mode: ... to here. * etc/snippets/text-mode: Moved from here... * etc/snippets/yas/text-mode: ... to here. * doc/contributing.texi ("The Perfect Setup"): Adjust yasnippet setup accordingly. Add tempel setup. Signed-off-by: Liliana Marie Prikler --- doc/contributing.texi | 18 +++- etc/snippets/scheme-mode/guix-bzr-reference | 7 -- etc/snippets/scheme-mode/guix-cvs-reference | 8 -- etc/snippets/scheme-mode/guix-git-reference | 7 -- etc/snippets/scheme-mode/guix-hg-reference | 7 -- etc/snippets/scheme-mode/guix-origin | 29 ------ etc/snippets/scheme-mode/guix-package | 46 ---------- etc/snippets/scheme-mode/guix-svn-reference | 7 -- etc/snippets/tempel/scheme-mode | 80 ++++++++++++++++ etc/snippets/tempel/text-mode | 101 +++++++++++++++++++++ .../text-mode/guix-commit-message-add-cl-package | 15 --- .../text-mode/guix-commit-message-add-package | 13 --- .../text-mode/guix-commit-message-remove-package | 13 --- .../text-mode/guix-commit-message-rename-package | 20 ---- .../text-mode/guix-commit-message-update-package | 26 ------ .../guix-commit-message-use-https-home-page | 9 -- etc/snippets/yas/scheme-mode/guix-bzr-reference | 7 ++ etc/snippets/yas/scheme-mode/guix-cvs-reference | 8 ++ etc/snippets/yas/scheme-mode/guix-git-reference | 7 ++ etc/snippets/yas/scheme-mode/guix-hg-reference | 7 ++ etc/snippets/yas/scheme-mode/guix-origin | 29 ++++++ etc/snippets/yas/scheme-mode/guix-package | 46 ++++++++++ etc/snippets/yas/scheme-mode/guix-svn-reference | 7 ++ .../text-mode/guix-commit-message-add-cl-package | 15 +++ .../yas/text-mode/guix-commit-message-add-package | 13 +++ .../text-mode/guix-commit-message-remove-package | 13 +++ .../text-mode/guix-commit-message-rename-package | 20 ++++ .../text-mode/guix-commit-message-update-package | 26 ++++++ .../guix-commit-message-use-https-home-page | 9 ++ 29 files changed, 402 insertions(+), 211 deletions(-) delete mode 100644 etc/snippets/scheme-mode/guix-bzr-reference delete mode 100644 etc/snippets/scheme-mode/guix-cvs-reference delete mode 100644 etc/snippets/scheme-mode/guix-git-reference delete mode 100644 etc/snippets/scheme-mode/guix-hg-reference delete mode 100644 etc/snippets/scheme-mode/guix-origin delete mode 100644 etc/snippets/scheme-mode/guix-package delete mode 100644 etc/snippets/scheme-mode/guix-svn-reference create mode 100644 etc/snippets/tempel/scheme-mode create mode 100644 etc/snippets/tempel/text-mode delete mode 100644 etc/snippets/text-mode/guix-commit-message-add-cl-package delete mode 100644 etc/snippets/text-mode/guix-commit-message-add-package delete mode 100644 etc/snippets/text-mode/guix-commit-message-remove-package delete mode 100644 etc/snippets/text-mode/guix-commit-message-rename-package delete mode 100644 etc/snippets/text-mode/guix-commit-message-update-package delete mode 100644 etc/snippets/text-mode/guix-commit-message-use-https-home-page create mode 100644 etc/snippets/yas/scheme-mode/guix-bzr-reference create mode 100644 etc/snippets/yas/scheme-mode/guix-cvs-reference create mode 100644 etc/snippets/yas/scheme-mode/guix-git-reference create mode 100644 etc/snippets/yas/scheme-mode/guix-hg-reference create mode 100644 etc/snippets/yas/scheme-mode/guix-origin create mode 100644 etc/snippets/yas/scheme-mode/guix-package create mode 100644 etc/snippets/yas/scheme-mode/guix-svn-reference create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-add-cl-package create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-add-package create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-remove-package create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-rename-package create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-update-package create mode 100644 etc/snippets/yas/text-mode/guix-commit-message-use-https-home-page (limited to 'doc') diff --git a/doc/contributing.texi b/doc/contributing.texi index 02c7c5ae59..b1d236c011 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -320,15 +320,25 @@ s-expression, etc. @cindex reducing boilerplate We also provide templates for common git commit messages and package definitions in the @file{etc/snippets} directory. These templates can -be used with @url{https://joaotavora.github.io/yasnippet/, YASnippet} to -expand short trigger strings to interactive text snippets. You may want -to add the snippets directory to the @var{yas-snippet-dirs} variable in +be used to expand short trigger strings to interactive text snippets. If +you use @url{https://joaotavora.github.io/yasnippet/, YASnippet}, you +may want to add the @file{etc/snippets/yas} snippets directory to the +@var{yas-snippet-dirs} variable. If you use +@url{https://github.com/minad/tempel/, Tempel}, you may want to add the +@file{etc/snippets/tempel/*} path to the @var{tempel-path} variable in Emacs. @lisp ;; @r{Assuming the Guix checkout is in ~/src/guix.} +;; @r{Yasnippet configuration} (with-eval-after-load 'yasnippet - (add-to-list 'yas-snippet-dirs "~/src/guix/etc/snippets")) + (add-to-list 'yas-snippet-dirs "~/src/guix/etc/snippets/yas")) +;; @r{Tempel configuration} +(with-eval-after-load 'tempel + ;; Ensure tempel-path is a list -- it may also be a string. + (unless (listp 'tempel-path) + (setq tempel-path (list tempel-path))) + (add-to-list 'tempel-path "~/src/guix/etc/snippets/tempel/*")) @end lisp The commit message snippets depend on @url{https://magit.vc/, Magit} to diff --git a/etc/snippets/scheme-mode/guix-bzr-reference b/etc/snippets/scheme-mode/guix-bzr-reference deleted file mode 100644 index a801cc36f2..0000000000 --- a/etc/snippets/scheme-mode/guix-bzr-reference +++ /dev/null @@ -1,7 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-bzr-reference -# key: bzr-reference... -# -- -(bzr-reference - (url "$1") - (revision ${2:ref})) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-cvs-reference b/etc/snippets/scheme-mode/guix-cvs-reference deleted file mode 100644 index fbc5034b66..0000000000 --- a/etc/snippets/scheme-mode/guix-cvs-reference +++ /dev/null @@ -1,8 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-cvs-reference -# key: cvs-reference... -# -- -(cvs-reference - (root-directory "${1:root-directory}") - (module "${2:module}") - (revision "${3:revision}")) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-git-reference b/etc/snippets/scheme-mode/guix-git-reference deleted file mode 100644 index 29ca6a9c54..0000000000 --- a/etc/snippets/scheme-mode/guix-git-reference +++ /dev/null @@ -1,7 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-git-reference -# key: git-reference... -# -- -(git-reference - (url "$1") - (commit ${2:commit})) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-hg-reference b/etc/snippets/scheme-mode/guix-hg-reference deleted file mode 100644 index 95de16daae..0000000000 --- a/etc/snippets/scheme-mode/guix-hg-reference +++ /dev/null @@ -1,7 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-hg-reference -# key: hg-reference... -# -- -(hg-reference - (url "$1") - (changeset ${2:changeset})) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-origin b/etc/snippets/scheme-mode/guix-origin deleted file mode 100644 index eb0cdc8242..0000000000 --- a/etc/snippets/scheme-mode/guix-origin +++ /dev/null @@ -1,29 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-origin -# key: origin... -# -- -(origin - (method ${1:$$(yas-choose-value "url-fetch" - "url-fetch/tarbomb" - "url-fetch/zipbomb" - "cvs-fetch" - "git-fetch" - "hg-fetch" - "svn-fetch" - "bzr-fetch")}) - (uri ${1:$(cond ((equal yas-text "git-fetch") "git-reference...") - ((equal yas-text "svn-fetch") "svn-reference...") - ((equal yas-text "hg-fetch") "hg-reference...") - ((equal yas-text "cvs-fetch") "cvs-reference...") - ((equal yas-text "bzr-fetch") "bzr-reference...") - (t "(string-append \\"https://\\" version \\".tar.gz\\")"))}$0) - ${1:$(cond ((equal yas-text "git-fetch") - "(file-name (git-file-name name version))") - ((equal yas-text "hg-fetch") - "(file-name (hg-file-name name version))") - ((member yas-text '("svn-fetch" "cvs-fetch" "bzr-fetch")) - "(file-name (string-append name \\"-\\" version \\"-checkout\\"))") - (t ""))} - (sha256 - (base32 - "$2"))) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-package b/etc/snippets/scheme-mode/guix-package deleted file mode 100644 index 9ff6f997d1..0000000000 --- a/etc/snippets/scheme-mode/guix-package +++ /dev/null @@ -1,46 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-package -# key: package... -# -- -(define-public $1 - (package - (name "$1") - (version "$2") - (source origin...$0) - (build-system ${3:$$(yas-choose-value "android-ndk-build-system" - "ant-build-system" - "asdf-build-system" - "cargo-build-system" - "clojure-build-system" - "cmake-build-system" - "copy-build-system" - "dub-build-system" - "dune-build-system" - "emacs-build-system" - "font-build-system" - "glib-or-gtk-build-system" - "gnu-build-system" - "go-build-system" - "guile-build-system" - "haskell-build-system" - "julia-build-system" - "linux-module-build-system" - "maven-build-system" - "meson-build-system" - "minify-build-system" - "node-build-system" - "ocaml-build-system" - "perl-build-system" - "python-build-system" - "qt-build-system" - "r-build-system" - "rakudo-build-system" - "ruby-build-system" - "scons-build-system" - "texlive-build-system" - "trivial-build-system" - "waf-build-system")}) - (home-page "$4") - (synopsis "$5") - (description "$6") - (license $7))) \ No newline at end of file diff --git a/etc/snippets/scheme-mode/guix-svn-reference b/etc/snippets/scheme-mode/guix-svn-reference deleted file mode 100644 index 7d897dc690..0000000000 --- a/etc/snippets/scheme-mode/guix-svn-reference +++ /dev/null @@ -1,7 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-svn-reference -# key: svn-reference... -# -- -(svn-reference - (url "$1") - (revision ${2:svn-revision})) \ No newline at end of file diff --git a/etc/snippets/tempel/scheme-mode b/etc/snippets/tempel/scheme-mode new file mode 100644 index 0000000000..74157e098a --- /dev/null +++ b/etc/snippets/tempel/scheme-mode @@ -0,0 +1,80 @@ +-*- mode: lisp-data -*- + +scheme-mode + +(package... + "(define-public " (s name) + n> "(package" + n > "(name \"" (s name) "\")" + n > "(version \"" p "\")" + n > "(source origin...)" + n > "(build-system " (p "gnu") "-build-system)" + n > "(home-page \"" p "\")" + n > "(synopsis \"" p "\")" + n > "(description \"" p "\")" + n > "(license license:" (p "unknown") ")))" n) + +(origin... + "(origin" + n> "(method " (p "url-fetch" method) ")" + n> "(uri " (cl-case (and method (intern method)) + ('git-fetch "git-reference...") + ('svn-fetch "svn-reference...") + ('hg-fetch "hg-reference...") + ('cvs-fetch "cvs-reference...") + ('bzr-fetch "bzr-reference...") + (t "\"https://...\"")) + ")" + n> + (cl-case (and method (intern method)) + ('git-fetch + (insert "(file-name (git-file-name name version))") + (newline) + (indent-according-to-mode)) + ('hg-fetch + (insert "(file-name (hg-file-name name version))") + (newline) + (indent-according-to-mode)) + ('svn-fetch + (insert "(file-name (string-append name \"-\" version \"-checkout\"))") + (newline) + (indent-according-to-mode)) + ('cvs-fetch + (insert "(file-name (string-append name \"-\" version \"-checkout\"))") + (newline) + (indent-according-to-mode)) + ('bzr-fetch + (insert "(file-name (string-append name \"-\" version \"-checkout\"))") + (newline) + (indent-according-to-mode)) + (t "")) + > "(sha256" + n > "(base32 \"" + ;; hash of an empty directory + (p "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") "\")))") + +(git-reference... + "(git-reference" + n> "(url \"" p "\")" + n> "(commit \"" p "\"))") + +(svn-reference... + "(svn-reference" + n> "(url \"" p "\")" + n> "(revision \"" p "\"))") + +(cvs-reference... + "(cvs-reference" + n> "(root-directory \"" p "\")" + n> "(module \"" p "\")" + n> "(revision \"" p "\"))") + +(hg-reference... + "(hg-reference" + n> "(url \"" p "\")" + n> "(changeset \"" p "\"))") + +(bzr-reference... + "(bzr-reference" + n> "(url \"" p "\")" + n> "(revision \"" p "\"))") diff --git a/etc/snippets/tempel/text-mode b/etc/snippets/tempel/text-mode new file mode 100644 index 0000000000..a1400aac69 --- /dev/null +++ b/etc/snippets/tempel/text-mode @@ -0,0 +1,101 @@ +-*- mode: lisp-data -*- + +text-mode :when (and (fboundp 'git-commit-mode) (git-commit-mode)) + +(add\ + "gnu: Add " + (p + (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "\\+(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1))) + var ) "." n n + "* " (car (magit-staged-files)) " (" (s var ) "): New variable.") + +(remove\ + "gnu: Remove " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "\\-(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1))) + var) "." n n + "* " (car (magit-staged-files)) " (" (s var) "): Delete variable.") + +(rename\ + "gnu: " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "-(define-public " nil 'noerror) + (thing-at-point 'sexp 'no-properties))) + prev-var) + ": Rename package to " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "+(define-public " nil 'noerror) + (thing-at-point 'sexp 'no-properties))) + new-var) "." n n + "* " (car (magit-staged-files)) " (" (s prev-var) "): Define in terms of" n + "'deprecated-package'." n + "(" (s new-var) "): New variable, formerly known as \"" (s prev-var) "\".") + +(update\ + "gnu: " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1))) + var) + ": Update to " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (search-forward "name" nil 'noerror) + (search-forward "+" nil 'noerror) ; first change + (when (and (search-forward "version " nil 'noerror) + (looking-at-p "\"")) + (let ((end (save-excursion (search-forward "\")" nil 'noerror)))) + (when end + (forward-char) + (buffer-substring-no-properties (point) (- end 2)))))) + version) "." n n + "* " (car (magit-staged-files)) " (" (s var) "): Update to " (s version) "." + (mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files))) n) + +(addcl\ + "gnu: Add cl-" + (p (replace-regexp-in-string + "^cl-" "" (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "+(define-public " nil 'noerror) + (replace-regexp-in-string + "^sbcl-" "" + (thing-at-point 'sexp 'no-properties))))) + var) "." n n + "* " (car (magit-staged-files)) + " (cl-" (s var) ", ecl-" (s var) ", sbcl-" (s var) "): New variables.") + +(https\ + "gnu: " + (p (with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1))) + var) + ": Use HTTPS home page." n n + "* " (car (magit-staged-files)) " (" (s var) ")[home-page]: Use HTTPS." n + (mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files))) n) diff --git a/etc/snippets/text-mode/guix-commit-message-add-cl-package b/etc/snippets/text-mode/guix-commit-message-add-cl-package deleted file mode 100644 index e255736b05..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-add-cl-package +++ /dev/null @@ -1,15 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-add-cl-package -# key: addcl -# condition: git-commit-mode -# -- -gnu: Add ${1:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (beginning-of-buffer) - (when (search-forward "+(define-public " nil 'noerror) - (replace-regexp-in-string - "^sbcl-" "" - (thing-at-point 'sexp 'no-properties))))`}. - -* `(car (magit-staged-files))` (cl-${1:$(replace-regexp-in-string "^cl-" "" yas-text)}, ecl-$1, sbcl-$1): New variables. \ No newline at end of file diff --git a/etc/snippets/text-mode/guix-commit-message-add-package b/etc/snippets/text-mode/guix-commit-message-add-package deleted file mode 100644 index 7cebd4023a..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-add-package +++ /dev/null @@ -1,13 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-add-package -# key: add -# condition: git-commit-mode -# -- -gnu: Add ${1:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (goto-char (point-min)) - (when (re-search-forward "\\+(define-public \\(\\S-+\\)" nil 'noerror) - (match-string-no-properties 1)))`}. - -* `(car (magit-staged-files))` ($1): New variable. \ No newline at end of file diff --git a/etc/snippets/text-mode/guix-commit-message-remove-package b/etc/snippets/text-mode/guix-commit-message-remove-package deleted file mode 100644 index 0c1050f4fe..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-remove-package +++ /dev/null @@ -1,13 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-remove-package -# key: remove -# condition: git-commit-mode -# -- -gnu: Remove ${1:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (goto-char (point-min)) - (when (re-search-forward "\\-(define-public \\(\\S-+\\)" nil 'noerror) - (match-string-no-properties 1)))`}. - -* `(car (magit-staged-files))` ($1): Delete variable. diff --git a/etc/snippets/text-mode/guix-commit-message-rename-package b/etc/snippets/text-mode/guix-commit-message-rename-package deleted file mode 100644 index 9695ca1b3d..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-rename-package +++ /dev/null @@ -1,20 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-rename-package -# key: rename -# condition: git-commit-mode -# -- -gnu: ${1:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (beginning-of-buffer) - (when (search-forward "-(define-public " nil 'noerror) - (thing-at-point 'sexp 'no-properties)))`}: Rename package to ${2:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (beginning-of-buffer) - (when (search-forward "+(define-public " nil 'noerror) - (thing-at-point 'sexp 'no-properties)))`}. - -* `(car (magit-staged-files))` ($1): Define in terms of -'deprecated-package'. -($2): New variable, formerly known as "$1". \ No newline at end of file diff --git a/etc/snippets/text-mode/guix-commit-message-update-package b/etc/snippets/text-mode/guix-commit-message-update-package deleted file mode 100644 index b08df74a0b..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-update-package +++ /dev/null @@ -1,26 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-update-package -# key: update -# condition: git-commit-mode -# -- - -gnu: ${1:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (goto-char (point-min)) - (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)" nil 'noerror) - (match-string-no-properties 1)))`}: Update to ${2:`(with-temp-buffer - (magit-git-wash #'magit-diff-wash-diffs - "diff" "--staged") - (goto-char (point-min)) - (search-forward "name" nil 'noerror) - (search-forward "+" nil 'noerror) ; first change - (when (and (search-forward "version " nil 'noerror) - (looking-at-p "\"")) - (let ((end (save-excursion (search-forward "\")" nil 'noerror)))) - (when end - (forward-char) - (buffer-substring-no-properties (point) (- end 2))))))`}. - -* `(car (magit-staged-files))` ($1): Update to $2.$0 -`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")` \ No newline at end of file diff --git a/etc/snippets/text-mode/guix-commit-message-use-https-home-page b/etc/snippets/text-mode/guix-commit-message-use-https-home-page deleted file mode 100644 index df20d31a80..0000000000 --- a/etc/snippets/text-mode/guix-commit-message-use-https-home-page +++ /dev/null @@ -1,9 +0,0 @@ -# -*- mode: snippet -*- -# name: guix-commit-message-use-https-home-page -# key: https -# condition: git-commit-mode -# -- -gnu: $1: Use HTTPS home page URI. - -* `(car (magit-staged-files))` ($1)[home-page]: Use HTTPS URI. -`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")` \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-bzr-reference b/etc/snippets/yas/scheme-mode/guix-bzr-reference new file mode 100644 index 0000000000..a801cc36f2 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-bzr-reference @@ -0,0 +1,7 @@ +# -*- mode: snippet -*- +# name: guix-bzr-reference +# key: bzr-reference... +# -- +(bzr-reference + (url "$1") + (revision ${2:ref})) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-cvs-reference b/etc/snippets/yas/scheme-mode/guix-cvs-reference new file mode 100644 index 0000000000..fbc5034b66 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-cvs-reference @@ -0,0 +1,8 @@ +# -*- mode: snippet -*- +# name: guix-cvs-reference +# key: cvs-reference... +# -- +(cvs-reference + (root-directory "${1:root-directory}") + (module "${2:module}") + (revision "${3:revision}")) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-git-reference b/etc/snippets/yas/scheme-mode/guix-git-reference new file mode 100644 index 0000000000..29ca6a9c54 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-git-reference @@ -0,0 +1,7 @@ +# -*- mode: snippet -*- +# name: guix-git-reference +# key: git-reference... +# -- +(git-reference + (url "$1") + (commit ${2:commit})) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-hg-reference b/etc/snippets/yas/scheme-mode/guix-hg-reference new file mode 100644 index 0000000000..95de16daae --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-hg-reference @@ -0,0 +1,7 @@ +# -*- mode: snippet -*- +# name: guix-hg-reference +# key: hg-reference... +# -- +(hg-reference + (url "$1") + (changeset ${2:changeset})) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-origin b/etc/snippets/yas/scheme-mode/guix-origin new file mode 100644 index 0000000000..eb0cdc8242 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-origin @@ -0,0 +1,29 @@ +# -*- mode: snippet -*- +# name: guix-origin +# key: origin... +# -- +(origin + (method ${1:$$(yas-choose-value "url-fetch" + "url-fetch/tarbomb" + "url-fetch/zipbomb" + "cvs-fetch" + "git-fetch" + "hg-fetch" + "svn-fetch" + "bzr-fetch")}) + (uri ${1:$(cond ((equal yas-text "git-fetch") "git-reference...") + ((equal yas-text "svn-fetch") "svn-reference...") + ((equal yas-text "hg-fetch") "hg-reference...") + ((equal yas-text "cvs-fetch") "cvs-reference...") + ((equal yas-text "bzr-fetch") "bzr-reference...") + (t "(string-append \\"https://\\" version \\".tar.gz\\")"))}$0) + ${1:$(cond ((equal yas-text "git-fetch") + "(file-name (git-file-name name version))") + ((equal yas-text "hg-fetch") + "(file-name (hg-file-name name version))") + ((member yas-text '("svn-fetch" "cvs-fetch" "bzr-fetch")) + "(file-name (string-append name \\"-\\" version \\"-checkout\\"))") + (t ""))} + (sha256 + (base32 + "$2"))) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-package b/etc/snippets/yas/scheme-mode/guix-package new file mode 100644 index 0000000000..9ff6f997d1 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-package @@ -0,0 +1,46 @@ +# -*- mode: snippet -*- +# name: guix-package +# key: package... +# -- +(define-public $1 + (package + (name "$1") + (version "$2") + (source origin...$0) + (build-system ${3:$$(yas-choose-value "android-ndk-build-system" + "ant-build-system" + "asdf-build-system" + "cargo-build-system" + "clojure-build-system" + "cmake-build-system" + "copy-build-system" + "dub-build-system" + "dune-build-system" + "emacs-build-system" + "font-build-system" + "glib-or-gtk-build-system" + "gnu-build-system" + "go-build-system" + "guile-build-system" + "haskell-build-system" + "julia-build-system" + "linux-module-build-system" + "maven-build-system" + "meson-build-system" + "minify-build-system" + "node-build-system" + "ocaml-build-system" + "perl-build-system" + "python-build-system" + "qt-build-system" + "r-build-system" + "rakudo-build-system" + "ruby-build-system" + "scons-build-system" + "texlive-build-system" + "trivial-build-system" + "waf-build-system")}) + (home-page "$4") + (synopsis "$5") + (description "$6") + (license $7))) \ No newline at end of file diff --git a/etc/snippets/yas/scheme-mode/guix-svn-reference b/etc/snippets/yas/scheme-mode/guix-svn-reference new file mode 100644 index 0000000000..7d897dc690 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-svn-reference @@ -0,0 +1,7 @@ +# -*- mode: snippet -*- +# name: guix-svn-reference +# key: svn-reference... +# -- +(svn-reference + (url "$1") + (revision ${2:svn-revision})) \ No newline at end of file diff --git a/etc/snippets/yas/text-mode/guix-commit-message-add-cl-package b/etc/snippets/yas/text-mode/guix-commit-message-add-cl-package new file mode 100644 index 0000000000..e255736b05 --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-add-cl-package @@ -0,0 +1,15 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-add-cl-package +# key: addcl +# condition: git-commit-mode +# -- +gnu: Add ${1:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "+(define-public " nil 'noerror) + (replace-regexp-in-string + "^sbcl-" "" + (thing-at-point 'sexp 'no-properties))))`}. + +* `(car (magit-staged-files))` (cl-${1:$(replace-regexp-in-string "^cl-" "" yas-text)}, ecl-$1, sbcl-$1): New variables. \ No newline at end of file diff --git a/etc/snippets/yas/text-mode/guix-commit-message-add-package b/etc/snippets/yas/text-mode/guix-commit-message-add-package new file mode 100644 index 0000000000..7cebd4023a --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-add-package @@ -0,0 +1,13 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-add-package +# key: add +# condition: git-commit-mode +# -- +gnu: Add ${1:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "\\+(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1)))`}. + +* `(car (magit-staged-files))` ($1): New variable. \ No newline at end of file diff --git a/etc/snippets/yas/text-mode/guix-commit-message-remove-package b/etc/snippets/yas/text-mode/guix-commit-message-remove-package new file mode 100644 index 0000000000..0c1050f4fe --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-remove-package @@ -0,0 +1,13 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-remove-package +# key: remove +# condition: git-commit-mode +# -- +gnu: Remove ${1:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "\\-(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1)))`}. + +* `(car (magit-staged-files))` ($1): Delete variable. diff --git a/etc/snippets/yas/text-mode/guix-commit-message-rename-package b/etc/snippets/yas/text-mode/guix-commit-message-rename-package new file mode 100644 index 0000000000..9695ca1b3d --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-rename-package @@ -0,0 +1,20 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-rename-package +# key: rename +# condition: git-commit-mode +# -- +gnu: ${1:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "-(define-public " nil 'noerror) + (thing-at-point 'sexp 'no-properties)))`}: Rename package to ${2:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (beginning-of-buffer) + (when (search-forward "+(define-public " nil 'noerror) + (thing-at-point 'sexp 'no-properties)))`}. + +* `(car (magit-staged-files))` ($1): Define in terms of +'deprecated-package'. +($2): New variable, formerly known as "$1". \ No newline at end of file diff --git a/etc/snippets/yas/text-mode/guix-commit-message-update-package b/etc/snippets/yas/text-mode/guix-commit-message-update-package new file mode 100644 index 0000000000..b08df74a0b --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-update-package @@ -0,0 +1,26 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-update-package +# key: update +# condition: git-commit-mode +# -- + +gnu: ${1:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (when (re-search-forward "^[ ]*(define-public \\(\\S-+\\)" nil 'noerror) + (match-string-no-properties 1)))`}: Update to ${2:`(with-temp-buffer + (magit-git-wash #'magit-diff-wash-diffs + "diff" "--staged") + (goto-char (point-min)) + (search-forward "name" nil 'noerror) + (search-forward "+" nil 'noerror) ; first change + (when (and (search-forward "version " nil 'noerror) + (looking-at-p "\"")) + (let ((end (save-excursion (search-forward "\")" nil 'noerror)))) + (when end + (forward-char) + (buffer-substring-no-properties (point) (- end 2))))))`}. + +* `(car (magit-staged-files))` ($1): Update to $2.$0 +`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")` \ No newline at end of file diff --git a/etc/snippets/yas/text-mode/guix-commit-message-use-https-home-page b/etc/snippets/yas/text-mode/guix-commit-message-use-https-home-page new file mode 100644 index 0000000000..df20d31a80 --- /dev/null +++ b/etc/snippets/yas/text-mode/guix-commit-message-use-https-home-page @@ -0,0 +1,9 @@ +# -*- mode: snippet -*- +# name: guix-commit-message-use-https-home-page +# key: https +# condition: git-commit-mode +# -- +gnu: $1: Use HTTPS home page URI. + +* `(car (magit-staged-files))` ($1)[home-page]: Use HTTPS URI. +`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")` \ No newline at end of file -- cgit 1.4.1