From db65d7447c3adc46e2b24abfc07ae10c6c537df4 Mon Sep 17 00:00:00 2001 From: Peng Mei Yu via Guix-patches via Date: Thu, 23 Jul 2020 17:24:13 +0800 Subject: services: nix: Provide nix commands. * gnu/services/nix.scm (nix-service-type): Extend profile-service-type to provide nix commands. Signed-off-by: Oleg Pykhalov --- gnu/services/nix.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index 75b2df02dc..e73203c2c5 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Oleg Pykhalov +;;; Copyright © 2020 Peng Mei Yu ;;; ;;; This file is part of GNU Guix. ;;; @@ -134,7 +135,9 @@ GID." (extensions (list (service-extension shepherd-root-service-type nix-shepherd-service) (service-extension account-service-type nix-accounts) - (service-extension activation-service-type nix-activation))) + (service-extension activation-service-type nix-activation) + (service-extension profile-service-type + (compose list nix-configuration-package)))) (description "Run the Nix daemon.") (default-value (nix-configuration)))) -- cgit v1.2.3 From ee67d193b3d1ddd18b10e845d5a75fbbf904b9c2 Mon Sep 17 00:00:00 2001 From: Peng Mei Yu Date: Fri, 24 Jul 2020 14:11:43 +0800 Subject: services: nix: Export nix-configuration. * gnu/services/nix.scm (nix-configuration, nix-configuration?): Export. Signed-off-by: Oleg Pykhalov --- gnu/services/nix.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index e73203c2c5..7c58f0edd1 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -35,7 +35,10 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (guix modules) - #:export (nix-service-type)) + #:export (nix-service-type + + nix-configuration + nix-configuration?)) ;;; Commentary: ;;; -- cgit v1.2.3 From 3601d802d55106e36e3279680d4728dd3cfe3b4c Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 25 Jul 2020 11:48:37 +0300 Subject: services: nix: Fix typo. * gnu/services/nix.scm (): Fix typo. --- gnu/services/nix.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index 7c58f0edd1..ba94cfa721 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -55,7 +55,7 @@ (default #t)) (build-sandbox-items nix-configuration-build-sandbox-items ;list of strings (default '())) - (extra-config nix-configuration-extra-options ;list of strings + (extra-config nix-configuration-extra-config ;list of strings (default '()))) ;; Copied from gnu/services/base.scm -- cgit v1.2.3 From 64c6282e7fc69ff58e7257a7e72284f63f2f5956 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 25 Jul 2020 11:51:49 +0300 Subject: services: nix: Add extra-options. * gnu/services/nix.scm ()[extra-options]: New field. (nix-shepherd-service): Add this. (nix-activation): Add new line to the end of /etc/nix/nix.conf file. * doc/guix.texi (Miscellaneous Services)[Nix service]: Document this. --- doc/guix.texi | 3 +++ gnu/services/nix.scm | 10 +++++++--- 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index a6fc64bed8..e2b304ff63 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -27637,6 +27637,9 @@ This is a list of strings or objects appended to the This is a list of strings or objects appended to the configuration file. It is used to pass extra text to be added verbatim to the configuration file. + +@item @code{extra-options} (default: @code{'()}) +Extra command line options for @code{nix-service-type}. @end table @end deftp diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index ba94cfa721..93f46ef71e 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -56,6 +56,8 @@ (build-sandbox-items nix-configuration-build-sandbox-items ;list of strings (default '())) (extra-config nix-configuration-extra-config ;list of strings + (default '())) + (extra-options nix-configuration-extra-options ;list of strings (default '()))) ;; Copied from gnu/services/base.scm @@ -116,19 +118,21 @@ GID." '#$(map references-file (list package))) '#$build-sandbox-items)) - (for-each (cut display <>) '#$extra-config)))))))) + (for-each (cut display <>) '#$extra-config) + (newline)))))))) (define nix-shepherd-service ;; Return a for Nix. (match-lambda - (($ package _ ...) + (($ package _ _ _ extra-options) (list (shepherd-service (provision '(nix-daemon)) (documentation "Run nix-daemon.") (requirement '()) (start #~(make-forkexec-constructor - (list (string-append #$package "/bin/nix-daemon")))) + (list (string-append #$package "/bin/nix-daemon") + #$@extra-options))) (respawn? #f) (stop #~(make-kill-destructor))))))) -- cgit v1.2.3 From 79501f26ab6d82c0256ff786a5dfb0000b52ccd3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jul 2020 20:21:21 +0200 Subject: services: Add 'unattended-upgrade-service-type'. * gnu/services/admin.scm (): New record type. (%unattended-upgrade-log-file): New variable. (unattended-upgrade-mcron-jobs, unattended-upgrade-log-rotations): New procedures. (unattended-upgrade-service-type): New variable. * doc/guix.texi (Service Reference): Add 'provenance-service-type' anchor. (Unattended Upgrades): New section. --- doc/guix.texi | 113 +++++++++++++++++++++++++++++++++++++++ gnu/services/admin.scm | 140 ++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 251 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index ca96ecc298..d45deed21e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12926,6 +12926,7 @@ declaration. * Scheduled Job Execution:: The mcron service. * Log Rotation:: The rottlog service. * Networking Services:: Network setup, SSH daemon, etc. +* Unattended Upgrades:: Automated system upgrades. * X Window:: Graphical display. * Printing Services:: Local and remote printer support. * Desktop Services:: D-Bus and desktop services. @@ -15298,6 +15299,117 @@ Use this to add additional options and manage shared secrets out-of-band. @end table @end deftp +@node Unattended Upgrades +@subsection Unattended Upgrades + +@cindex unattended upgrades +@cindex upgrades, unattended +Guix provides a service to perform @emph{unattended upgrades}: +periodically, the system automatically reconfigures itself from the +latest Guix. Guix System has several properties that make unattended +upgrades safe: + +@itemize +@item +upgrades are transactional (either the upgrade succeeds or it fails, but +you cannot end up with an ``in-between'' system state); +@item +the upgrade log is kept---you can view it with @command{guix system +list-generations}---and you can roll back to any previous generation, +should the upgraded system fail to behave as intended; +@item +channel code is authenticated so you know you can only run genuine code +(@pxref{Channels}); +@item +@command{guix system reconfigure} prevents downgrades, which makes it +immune to @dfn{downgrade attacks}. +@end itemize + +To set up unattended upgrades, add an instance of +@code{unattended-upgrade-service-type} like the one below to the list of +your operating system services: + +@lisp +(service unattended-upgrade-service-type) +@end lisp + +The defaults above set up weekly upgrades: every Sunday at midnight. +You do not need to provide the operating system configuration file: it +uses @file{/run/current-system/configuration.scm}, which ensures it +always uses your latest configuration---@pxref{provenance-service-type}, +for more information about this file. + +There are several things that can be configured, in particular the +periodicity and services (daemons) to be restarted upon completion. +When the upgrade is successful, the service takes care of deleting +system generations older that some threshold, as per @command{guix +system delete-generations}. See the reference below for details. + +To ensure that upgrades are actually happening, you can run +@command{guix system describe}. To investigate upgrade failures, visit +the unattended upgrade log file (see below). + +@defvr {Scheme Variable} unattended-upgrade-service-type +This is the service type for unattended upgrades. It sets up an mcron +job (@pxref{Scheduled Job Execution}) that runs @command{guix system +reconfigure} from the latest version of the specified channels. + +Its value must be a @code{unattended-upgrade-configuration} record (see +below). +@end defvr + +@deftp {Data Type} unattended-upgrade-configuration +This data type represents the configuration of the unattended upgrade +service. The following fields are available: + +@table @asis +@item @code{schedule} (default: @code{"30 01 * * 0"}) +This is the schedule of upgrades, expressed as a gexp containing an +mcron job schedule (@pxref{Guile Syntax, mcron job specifications,, +mcron, GNU@tie{}mcron}). + +@item @code{channels} (default: @code{#~%default-channels}) +This gexp specifies the channels to use for the upgrade +(@pxref{Channels}). By default, the tip of the official @code{guix} +channel is used. + +@item @code{services-to-restart} (default: @code{'(mcron)}) +This field specifies the Shepherd services to restart when the upgrade +completes. + +Those services are restarted right away upon completion, as with +@command{herd restart}, which ensures that the latest version is +running---remember that by default @command{guix system reconfigure} +only restarts services that are not currently running, which is +conservative: it minimizes disruption but leaves outdated services +running. + +By default, the @code{mcron} service is restarted. This ensures that +the latest version of the unattended upgrade job will be used next time. + +@item @code{system-expiration} (default: @code{(* 3 30 24 3600)}) +This is the expiration time in seconds for system generations. System +generations older that this amount of time are deleted with +@command{guix system delete-generations} when an upgrade completes. + +@quotation Note +The unattended upgrade service does not run the garbage collector. You +will probably want to set up your own mcron job to run @command{guix gc} +periodically. +@end quotation + +@item @code{maximum-duration} (default: @code{3600}) +Maximum duration in seconds for the upgrade; past that time, the upgrade +aborts. + +This is primarily useful to ensure the upgrade does not end up +rebuilding or re-downloading ``the world''. + +@item @code{log-file} (default: @code{"/var/log/unattended-upgrade.log"}) +File where unattended upgrades are logged. +@end table +@end deftp + @node X Window @subsection X Window @@ -29628,6 +29740,7 @@ extend it by passing it lists of packages to add to the system profile. @end defvr @cindex provenance tracking, of the operating system +@anchor{provenance-service-type} @defvr {Scheme Variable} provenance-service-type This is the type of the service that records @dfn{provenance meta-data} in the system itself. It creates several files under diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index 89fa73920d..6ed3de9423 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Jan Nieuwenhuizen -;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Brice Waegeneire ;;; ;;; This file is part of GNU Guix. @@ -20,10 +20,13 @@ (define-module (gnu services admin) #:use-module (gnu packages admin) + #:use-module (gnu packages certs) + #:use-module (gnu packages package-management) #:use-module (gnu services) #:use-module (gnu services mcron) #:use-module (gnu services shepherd) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix records) #:use-module (srfi srfi-1) @@ -41,7 +44,17 @@ rottlog-configuration rottlog-configuration? rottlog-service - rottlog-service-type)) + rottlog-service-type + + unattended-upgrade-service-type + unattended-upgrade-configuration + unattended-upgrade-configuration? + unattended-upgrade-configuration-channels + unattended-upgrade-configuration-schedule + unattended-upgrade-configuration-services-to-restart + unattended-upgrade-configuration-system-expiration + unattended-upgrade-configuration-maximum-duration + unattended-upgrade-configuration-log-file)) ;;; Commentary: ;;; @@ -177,4 +190,127 @@ Old log files are removed or compressed according to the configuration.") rotations))))) (default-value (rottlog-configuration)))) + +;;; +;;; Unattended upgrade. +;;; + +(define-record-type* + unattended-upgrade-configuration make-unattended-upgrade-configuration + unattended-upgrade-configuration? + (schedule unattended-upgrade-configuration-schedule + (default "30 01 * * 0")) + (channels unattended-upgrade-configuration-channels + (default #~%default-channels)) + (services-to-restart unattended-upgrade-configuration-services-to-restart + (default '(mcron))) + (system-expiration unattended-upgrade-system-expiration + (default (* 3 30 24 3600))) + (maximum-duration unattended-upgrade-maximum-duration + (default 3600)) + (log-file unattended-upgrade-configuration-log-file + (default %unattended-upgrade-log-file))) + +(define %unattended-upgrade-log-file + "/var/log/unattended-upgrade.log") + +(define (unattended-upgrade-mcron-jobs config) + (define channels + (scheme-file "channels.scm" + (unattended-upgrade-configuration-channels config))) + + (define log + (unattended-upgrade-configuration-log-file config)) + + (define services + (unattended-upgrade-configuration-services-to-restart config)) + + (define expiration + (unattended-upgrade-system-expiration config)) + + (define code + (with-imported-modules (source-module-closure '((guix build utils) + (gnu services herd))) + #~(begin + (use-modules (guix build utils) + (gnu services herd) + (srfi srfi-19) + (srfi srfi-34)) + + (define log + (open-file #$log "a0")) + + (define (timestamp) + (date->string (time-utc->date (current-time time-utc)) + "[~4]")) + + (define (alarm-handler . _) + (format #t "~a time is up, aborting upgrade~%" + (timestamp)) + (exit 1)) + + (define-syntax-rule (with-logging exp ...) + (with-output-to-port log + (lambda () + (with-error-to-port log + (lambda () + exp ...))))) + + ;; 'guix time-machine' needs X.509 certificates to authenticate the + ;; Git host. + (setenv "SSL_CERT_DIR" + #$(file-append nss-certs "/etc/ssl/certs")) + + ;; Make sure the upgrade doesn't take too long. + (sigaction SIGALRM alarm-handler) + (alarm #$(unattended-upgrade-maximum-duration config)) + + (with-logging + (format #t "~a starting upgrade...~%" (timestamp)) + (guard (c ((invoke-error? c) + (report-invoke-error c))) + (invoke #$(file-append guix "/bin/guix") + "time-machine" "-C" #$channels + "--" "system" "reconfigure" + "/run/current-system/configuration.scm") + + ;; 'guix system delete-generations' fails when there's no + ;; matching generation. Thus, catch 'invoke-error?'. + (guard (c ((invoke-error? c) + (report-invoke-error c))) + (invoke #$(file-append guix "/bin/guix") + "system" "delete-generations" + #$(string-append (number->string expiration) + "s"))) + + (format #t "~a restarting services...~%" (timestamp)) + (for-each restart-service '#$services) + + ;; XXX: If 'mcron' has been restarted, perhaps this isn't + ;; reached. + (format #t "~a upgrade complete~%" (timestamp))))))) + + (define upgrade + (program-file "unattended-upgrade" code)) + + (list #~(job #$(unattended-upgrade-configuration-schedule config) + #$upgrade))) + +(define (unattended-upgrade-log-rotations config) + (list (log-rotation + (files + (list (unattended-upgrade-configuration-log-file config)))))) + +(define unattended-upgrade-service-type + (service-type + (name 'unattended-upgrade) + (extensions + (list (service-extension mcron-service-type + unattended-upgrade-mcron-jobs) + (service-extension rottlog-service-type + unattended-upgrade-log-rotations))) + (description + "Periodically upgrade the system from the current configuration.") + (default-value (unattended-upgrade-configuration)))) + ;;; admin.scm ends here -- cgit v1.2.3 From 73cb3e103f35356b83cb091f15c536c21bf53981 Mon Sep 17 00:00:00 2001 From: Robin Green Date: Sun, 19 Jul 2020 08:32:31 +0100 Subject: services: auditd: Provide default configuration directory. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/auditd.scm (auditd.conf) (%default-auditd-configuration-directory): New variables. (): Switch to 'define-record-type*'. [configuration-directory]: New field. (auditd-shepherd-service): Honor 'configuration-directory'. Pass #:pid-file. (auditd-service-type)[description]: Tweak. [default-value]: Provide 'configuration-directory'. * doc/guix.texi (Miscellaneous Services): Update docs to reflect changes. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 11 +++++++++-- gnu/services/auditd.scm | 41 ++++++++++++++++++++++++++++++----------- 2 files changed, 39 insertions(+), 13 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index d45deed21e..d4557b360a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -27612,10 +27612,12 @@ Network access @command{auditctl} from the @code{audit} package can be used in order to add or remove events to be tracked (until the next reboot). In order to permanently track events, put the command line arguments -of auditctl into @file{/etc/audit/audit.rules}. +of auditctl into a file called @code{audit.rules} in the configuration +directory (see below). @command{aureport} from the @code{audit} package can be used in order to view a report of all recorded events. -The audit daemon usually logs into the directory @file{/var/log/audit}. +The audit daemon by default logs into the file +@file{/var/log/audit.log}. @end defvr @@ -27627,6 +27629,11 @@ This is the data type representing the configuration of auditd. @item @code{audit} (default: @code{audit}) The audit package to use. +@item @code{configuration-directory} (default: @code{%default-auditd-configuration-directory}) +The directory containing the configuration file for the audit package, which +must be named @code{auditd.conf}, and optionally some audit rules to +instantiate on startup. + @end table @end deftp diff --git a/gnu/services/auditd.scm b/gnu/services/auditd.scm index 8a9292015f..cffc226ec9 100644 --- a/gnu/services/auditd.scm +++ b/gnu/services/auditd.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2020 Robin Green ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,29 +27,47 @@ #:use-module (guix gexp) #:use-module (guix packages) #:export (auditd-configuration - auditd-service-type)) + auditd-service-type + %default-auditd-configuration-directory)) -; /etc/audit/audit.rules +(define auditd.conf + (plain-file "auditd.conf" "log_file = /var/log/audit.log\nlog_format = \ +ENRICHED\nfreq = 1\nspace_left = 5%\nspace_left_action = \ +syslog\nadmin_space_left_action = ignore\ndisk_full_action = \ +ignore\ndisk_error_action = syslog\n")) -(define-configuration auditd-configuration - (audit - (package audit) - "Audit package.")) +(define %default-auditd-configuration-directory + (computed-file "auditd" + #~(begin + (mkdir #$output) + (copy-file #$auditd.conf + (string-append #$output "/auditd.conf"))))) + +(define-record-type* + auditd-configuration make-auditd-configuration + auditd-configuration? + (audit auditd-configuration-audit ; package + (default audit)) + (configuration-directory auditd-configuration-configuration-directory)) ; file-like (define (auditd-shepherd-service config) - (let* ((audit (auditd-configuration-audit config))) + (let* ((audit (auditd-configuration-audit config)) + (configuration-directory (auditd-configuration-configuration-directory config))) (list (shepherd-service - (documentation "Auditd allows you to audit file system accesses.") + (documentation "Auditd allows you to audit file system accesses and process execution.") (provision '(auditd)) (start #~(make-forkexec-constructor - (list (string-append #$audit "/sbin/auditd")))) + (list (string-append #$audit "/sbin/auditd") "-c" #$configuration-directory) + #:pid-file "/var/run/auditd.pid")) (stop #~(make-kill-destructor)))))) (define auditd-service-type (service-type (name 'auditd) - (description "Allows auditing file system accesses.") + (description "Allows auditing file system accesses and process execution.") (extensions (list (service-extension shepherd-root-service-type auditd-shepherd-service))) - (default-value (auditd-configuration)))) + (default-value + (auditd-configuration + (configuration-directory %default-auditd-configuration-directory))))) -- cgit v1.2.3 From 3bf4761e397ade056ebb7f5891797317768e6442 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Tue, 28 Jul 2020 13:55:28 +0200 Subject: services: postgresql: Provide postgresql commands. * gnu/services/databases.scm (postgresql-service-type): Extend profile-service-type to provide postgresql commands. --- gnu/services/databases.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 473ece4e97..2bddf70f71 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -276,7 +276,9 @@ host all all ::1/128 md5")) (service-extension activation-service-type postgresql-activation) (service-extension account-service-type - (const %postgresql-accounts)))) + (const %postgresql-accounts)) + (service-extension profile-service-type + (compose list postgresql-configuration-postgresql)))) (default-value (postgresql-configuration)))) (define* (postgresql-service #:key (postgresql postgresql) -- cgit v1.2.3 From 587e0d911dfff81647015e89847084b606e68f71 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 22 Jul 2020 21:07:31 +0300 Subject: services: Add zram-device-service. * gnu/services/linux.scm (): New record. (zram-device-service-type): New variable. * doc/guix.texi (Linux Services): Document it. * tests/services/linux.scm (zram-swap-device-test): New tests. --- doc/guix.texi | 45 +++++++++++++++++++++++++++ gnu/services/linux.scm | 81 +++++++++++++++++++++++++++++++++++++++++++++++- tests/services/linux.scm | 37 ++++++++++++++++++++++ 3 files changed, 162 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index c23ed8d715..f9cb7f204b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -27283,6 +27283,51 @@ parameters, can be done as follow: @end lisp @end deffn +@cindex zram +@cindex compressed swap +@cindex Compressed RAM-based block devices +@subsubheading Zram Device Service + +The Zram device service provides a compressed swap device in system +memory. The Linux Kernel documentation has more information about +@uref{https://www.kernel.org/doc/html/latest/admin-guide/blockdev/zram.html,zram} +devices. + +@deffn {Scheme Variable} zram-device-service-type +This service creates the zram block device, formats it as swap and +enables it as a swap device. The service's value is a +@code{zram-device-configuration} record. + +@deftp {Data Type} zram-device-configuration +This is the data type representing the configuration for the zram-device +service. + +@table @asis +@item @code{size} (default @var{"1G"}) +This is the amount of space you wish to provide for the zram device. It +accepts a string and can be a number of bytes or use a suffix, eg.: +@var{"512M"} or @var{1024000}. +@item @code{compression-algorithm} (default @var{'lzo}) +This is the compression algorithm you wish to use. It is difficult to +list all the possible compression options, but common ones supported by +Guix's Linux Libre Kernel include @var{'lzo}, @var{'lz4} and @var{'zstd}. +@item @code{memory-limit} (default @var{0}) +This is the maximum amount of memory which the zram device can use. +Setting it to '0' disables the limit. While it is generally expected +that compression will be 2:1, it is possible that uncompressable data +can be written to swap and this is a method to limit how much memory can +be used. It accepts a string and can be a number of bytes or use a +suffix, eg.: @var{"2G"}. +@item @code{priority} (default @var{-1}) +This is the priority of the swap device created from the zram device. +@code{swapon} accepts values between -1 and 32767, with higher values +indicating higher priority. Higher priority swap will generally be used +first. +@end table + +@end deftp +@end deffn + @node Hurd Services @subsection Hurd Services diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm index 12934c2084..ec42663a11 100644 --- a/gnu/services/linux.scm +++ b/gnu/services/linux.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2020 Brice Waegeneire +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module (guix records) #:use-module (guix modules) #:use-module (gnu services) + #:use-module (gnu services base) #:use-module (gnu services shepherd) #:use-module (gnu packages linux) #:use-module (srfi srfi-1) @@ -42,7 +44,15 @@ earlyoom-configuration-send-notification-command earlyoom-service-type - kernel-module-loader-service-type)) + kernel-module-loader-service-type + + zram-device-configuration + zram-device-configuration? + zram-device-configuration-size + zram-device-configuration-compression-algorithm + zram-device-configuration-memory-limit + zram-device-configuration-priority + zram-device-service-type)) ;;; @@ -177,3 +187,72 @@ representation." (compose concatenate) (extend append) (default-value '()))) + + +;;; +;;; Kernel module loader. +;;; + +(define-record-type* + zram-device-configuration make-zram-device-configuration + zram-device-configuration? + (size zram-device-configration-size + (default "1G")) ; string or integer + (compression-algorithm zram-device-configuration-compression-algorithm + (default 'lzo)) ; symbol + (memory-limit zram-device-configuration-memory-limit + (default 0)) ; string or integer + (priority zram-device-configuration-priority + (default -1))) ; integer + +(define (zram-device-configuration->udev-string config) + "Translate a into a string which can be +placed in a udev rules file." + (match config + (($ size compression-algorithm memory-limit priority) + (string-append + "KERNEL==\"zram0\", " + "ATTR{comp_algorithm}=\"" (symbol->string compression-algorithm) "\" " + (if (not (or (equal? "0" size) + (equal? 0 size))) + (string-append "ATTR{disksize}=\"" (if (number? size) + (number->string size) + size) + "\" ") + "") + (if (not (or (equal? "0" memory-limit) + (equal? 0 memory-limit))) + (string-append "ATTR{mem_limit}=\"" (if (number? memory-limit) + (number->string memory-limit) + memory-limit) + "\" ") + "") + "RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" " + "RUN+=\"/run/current-system/profile/sbin/swapon " + (if (not (equal? -1 priority)) + (string-append "--priority " (number->string priority) " ") + "") + "/dev/zram0\"\n")))) + +(define %zram-device-config + `("modprobe.d/zram.conf" + ,(plain-file "zram.conf" + "options zram num_devices=1"))) + +(define (zram-device-udev-rule config) + (file->udev-rule "99-zram.rules" + (plain-file "99-zram.rules" + (zram-device-configuration->udev-string config)))) + +(define zram-device-service-type + (service-type + (name 'zram) + (default-value (zram-device-configuration)) + (extensions + (list (service-extension kernel-module-loader-service-type + (const (list "zram"))) + (service-extension etc-service-type + (const (list %zram-device-config))) + (service-extension udev-service-type + (compose list zram-device-udev-rule)))) + (description "Creates a zram swap device."))) diff --git a/tests/services/linux.scm b/tests/services/linux.scm index 8ad119c49f..e2cd191e48 100644 --- a/tests/services/linux.scm +++ b/tests/services/linux.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,4 +55,40 @@ "-N" "python \"/some/path/notify-all-users.py\"") (earlyoom-configuration->command-line-args %earlyoom-configuration-sample)) + +;;; +;;; Zram swap device. +;;; + +(define zram-device-configuration->udev-string + (@@ (gnu services linux) zram-device-configuration->udev-string)) + +(define %zram-swap-device-test-1 + (zram-device-configuration + (size "2G") + (compression-algorithm 'zstd) + (memory-limit "1G") + (priority 42))) + +(test-equal "zram-swap-device-test-1" + "KERNEL==\"zram0\", ATTR{comp_algorithm}=\"zstd\" ATTR{disksize}=\"2G\" ATTR{mem_limit}=\"1G\" RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" RUN+=\"/run/current-system/profile/sbin/swapon --priority 42 /dev/zram0\"\n" + (zram-device-configuration->udev-string %zram-swap-device-test-1)) + +(define %zram-swap-device-test-2 + (zram-device-configuration + (size 1048576) ; 1M + (compression-algorithm 'lz4))) + +(test-equal "zram-swap-device-test-2" + "KERNEL==\"zram0\", ATTR{comp_algorithm}=\"lz4\" ATTR{disksize}=\"1048576\" RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" RUN+=\"/run/current-system/profile/sbin/swapon /dev/zram0\"\n" + (zram-device-configuration->udev-string %zram-swap-device-test-2)) + +(define %zram-swap-device-test-3 + (zram-device-configuration + (memory-limit (* 512 1000)))) + +(test-equal "zram-swap-device-test-3" + "KERNEL==\"zram0\", ATTR{comp_algorithm}=\"lzo\" ATTR{disksize}=\"1G\" ATTR{mem_limit}=\"512000\" RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" RUN+=\"/run/current-system/profile/sbin/swapon /dev/zram0\"\n" + (zram-device-configuration->udev-string %zram-swap-device-test-3)) + (test-end "linux-services") -- cgit v1.2.3 From 2b68a96422575b14e54c9a7e3d0033f6231a6b4d Mon Sep 17 00:00:00 2001 From: Alexey Abramov Date: Sun, 16 Aug 2020 10:09:07 +0200 Subject: services: docker: Add 'enable-iptables?' argument. * gnu/services/docker.scm (docker-configuration): Define the argument. * gnu/services/docker.scm (docker-shepherd-service): Use it. * doc/guix.texi (Docker Service): Document it. Signed-off-by: Mathieu Othacehe --- doc/guix.texi | 3 +++ gnu/services/docker.scm | 11 +++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index 587c004bee..e0c138533f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -27660,6 +27660,9 @@ Enable or disable the use of the Docker user-land networking proxy. @item @code{debug?} (default @code{#f}) Enable or disable debug output. +@item @code{enable-iptables?} (default @code{#t}) +Enable or disable the addition of iptables rules. + @end table @end deftp diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm index 937dff7bdb..380a942ed2 100644 --- a/gnu/services/docker.scm +++ b/gnu/services/docker.scm @@ -56,7 +56,10 @@ loop-back communications.") "Enable or disable the user-land proxy (enabled by default).") (debug? (boolean #f) - "Enable or disable debug output.")) + "Enable or disable debug output.") + (enable-iptables? + (boolean #t) + "Enable addition of iptables rules (enabled by default).")) (define %docker-accounts (list (user-group (name "docker") (system? #t)))) @@ -91,6 +94,7 @@ loop-back communications.") (define (docker-shepherd-service config) (let* ((docker (docker-configuration-docker config)) (enable-proxy? (docker-configuration-enable-proxy? config)) + (enable-iptables? (docker-configuration-enable-iptables? config)) (proxy (docker-configuration-proxy config)) (debug? (docker-configuration-debug? config))) (shepherd-service @@ -115,7 +119,10 @@ loop-back communications.") '()) (if #$enable-proxy? "--userland-proxy" "") "--userland-proxy-path" (string-append #$proxy - "/bin/proxy")) + "/bin/proxy") + (if #$enable-iptables? + "--iptables" + "--iptables=false")) #:pid-file "/var/run/docker.pid" #:log-file "/var/log/docker.log")) (stop #~(make-kill-destructor))))) -- cgit v1.2.3 From 0ba3a38bb2a94dfcf0c422b8b880aa0e4608b5b2 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Sun, 16 Aug 2020 16:33:43 +0300 Subject: services: connman-shepherd-service: Don't use short flags. * gnu/services/networking.scm (connman-shepherd-service): Use the long flag options for the start command. --- gnu/services/networking.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 353fdce2bb..e45b116218 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver -;;; Copyright © 2016, 2018 Efraim Flashner +;;; Copyright © 2016, 2018, 2020 Efraim Flashner ;;; Copyright © 2016 John Darrington ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2017 Thomas Danckaert @@ -1163,7 +1163,8 @@ wireless networking.")))) (start #~(make-forkexec-constructor (list (string-append #$connman "/sbin/connmand") - "-n" "-r" + "--nodaemon" + "--nodnsproxy" #$@(if disable-vpn? '("--noplugin=vpn") '())) ;; As connman(8) notes, when passing '-n', connman -- cgit v1.2.3 From 7f9018aaf6edbeab9a8e67f9852fd273b5bef1c1 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 18 Aug 2020 21:12:12 +0200 Subject: services: Allow (service accountsservice-service-type). * gnu/services/desktop.scm (accountsservice-service-type) [default-value]: Set to accountsservice. --- gnu/services/desktop.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 9e45743586..bdbea5dddf 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -836,7 +836,8 @@ when they log out." (list (service-extension activation-service-type (const %accountsservice-activation)) (service-extension dbus-root-service-type list) - (service-extension polkit-service-type list))))) + (service-extension polkit-service-type list))) + (default-value accountsservice))) (define* (accountsservice-service #:key (accountsservice accountsservice)) "Return a service that runs AccountsService, a system service that -- cgit v1.2.3 From 0d203eeaa69a42a914a9981449805014ab6b7b77 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Aug 2020 14:52:39 +0200 Subject: services: unattended-upgrade: Add 'operating-system-file' field. * gnu/services/admin.scm ()[operating-system-file]: New field. (unattended-upgrade-mcron-jobs): Honor it. * doc/guix.texi (Unattended Upgrades): Document it. --- doc/guix.texi | 23 +++++++++++++++++++++++ gnu/services/admin.scm | 9 +++++++-- 2 files changed, 30 insertions(+), 2 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index 4264ce5194..fed904411a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15393,6 +15393,29 @@ This gexp specifies the channels to use for the upgrade (@pxref{Channels}). By default, the tip of the official @code{guix} channel is used. +@item @code{operating-system-file} (default: @code{"/run/current-system/configuration.scm"}) +This field specifies the operating system configuration file to use. +The default is to reuse the config file of the current configuration. + +There are cases, though, where referring to +@file{/run/current-system/configuration.scm} is not enough, for instance +because that file refers to extra files (SSH public keys, extra +configuration files, etc.) @i{via} @code{local-file} and similar +constructs. For those cases, we recommend something along these lines: + +@lisp +(unattended-upgrade-configuration + (operating-system-file + (file-append (local-file "." "config-dir" #:recursive? #t) + "/config.scm"))) +@end lisp + +The effect here is to import all of the current directory into the +store, and to refer to @file{config.scm} within that directory. +Therefore, uses of @code{local-file} within @file{config.scm} will work +as expected. @xref{G-Expressions}, for information about +@code{local-file} and @code{file-append}. + @item @code{services-to-restart} (default: @code{'(mcron)}) This field specifies the Shepherd services to restart when the upgrade completes. diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index 6ed3de9423..61bc17b2fe 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -49,6 +49,7 @@ unattended-upgrade-service-type unattended-upgrade-configuration unattended-upgrade-configuration? + unattended-upgrade-configuration-operating-system-file unattended-upgrade-configuration-channels unattended-upgrade-configuration-schedule unattended-upgrade-configuration-services-to-restart @@ -198,6 +199,8 @@ Old log files are removed or compressed according to the configuration.") (define-record-type* unattended-upgrade-configuration make-unattended-upgrade-configuration unattended-upgrade-configuration? + (operating-system-file unattended-upgrade-operating-system-file + (default "/run/current-system/configuration.scm")) (schedule unattended-upgrade-configuration-schedule (default "30 01 * * 0")) (channels unattended-upgrade-configuration-channels @@ -228,6 +231,9 @@ Old log files are removed or compressed according to the configuration.") (define expiration (unattended-upgrade-system-expiration config)) + (define config-file + (unattended-upgrade-operating-system-file config)) + (define code (with-imported-modules (source-module-closure '((guix build utils) (gnu services herd))) @@ -271,8 +277,7 @@ Old log files are removed or compressed according to the configuration.") (report-invoke-error c))) (invoke #$(file-append guix "/bin/guix") "time-machine" "-C" #$channels - "--" "system" "reconfigure" - "/run/current-system/configuration.scm") + "--" "system" "reconfigure" #$config-file) ;; 'guix system delete-generations' fails when there's no ;; matching generation. Thus, catch 'invoke-error?'. -- cgit v1.2.3 From fe42e5f39c9b36f02beec246b376a50e41114b84 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Aug 2020 22:59:43 +0200 Subject: services: unattended-upgrade: Log output of the 'guix' commands. Fixes . Reported by Jesse Gibbons . Until now the stdout/stderr file descriptors were not redirected. * gnu/services/admin.scm (unattended-upgrade-mcron-jobs)[code]: Remove 'with-logging' and use 'redirect-port' instead. --- gnu/services/admin.scm | 56 +++++++++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 30 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index 61bc17b2fe..b34b990f32 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -255,13 +255,6 @@ Old log files are removed or compressed according to the configuration.") (timestamp)) (exit 1)) - (define-syntax-rule (with-logging exp ...) - (with-output-to-port log - (lambda () - (with-error-to-port log - (lambda () - exp ...))))) - ;; 'guix time-machine' needs X.509 certificates to authenticate the ;; Git host. (setenv "SSL_CERT_DIR" @@ -271,29 +264,32 @@ Old log files are removed or compressed according to the configuration.") (sigaction SIGALRM alarm-handler) (alarm #$(unattended-upgrade-maximum-duration config)) - (with-logging - (format #t "~a starting upgrade...~%" (timestamp)) - (guard (c ((invoke-error? c) - (report-invoke-error c))) - (invoke #$(file-append guix "/bin/guix") - "time-machine" "-C" #$channels - "--" "system" "reconfigure" #$config-file) - - ;; 'guix system delete-generations' fails when there's no - ;; matching generation. Thus, catch 'invoke-error?'. - (guard (c ((invoke-error? c) - (report-invoke-error c))) - (invoke #$(file-append guix "/bin/guix") - "system" "delete-generations" - #$(string-append (number->string expiration) - "s"))) - - (format #t "~a restarting services...~%" (timestamp)) - (for-each restart-service '#$services) - - ;; XXX: If 'mcron' has been restarted, perhaps this isn't - ;; reached. - (format #t "~a upgrade complete~%" (timestamp))))))) + ;; Redirect stdout/stderr to LOG to save the output of 'guix' below. + (redirect-port log (current-output-port)) + (redirect-port log (current-error-port)) + + (format #t "~a starting upgrade...~%" (timestamp)) + (guard (c ((invoke-error? c) + (report-invoke-error c))) + (invoke #$(file-append guix "/bin/guix") + "time-machine" "-C" #$channels + "--" "system" "reconfigure" #$config-file) + + ;; 'guix system delete-generations' fails when there's no + ;; matching generation. Thus, catch 'invoke-error?'. + (guard (c ((invoke-error? c) + (report-invoke-error c))) + (invoke #$(file-append guix "/bin/guix") + "system" "delete-generations" + #$(string-append (number->string expiration) + "s"))) + + (format #t "~a restarting services...~%" (timestamp)) + (for-each restart-service '#$services) + + ;; XXX: If 'mcron' has been restarted, perhaps this isn't + ;; reached. + (format #t "~a upgrade complete~%" (timestamp)))))) (define upgrade (program-file "unattended-upgrade" code)) -- cgit v1.2.3 From 755f365b02b42a5d1e8ef3000dadef069553a478 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 5 Jul 2020 12:23:21 +0200 Subject: linux-libre: Support module compression. This commit adds support for GZIP compression for linux-libre kernel modules. The initrd modules are kept uncompressed as the initrd is already compressed as a whole. The linux-libre kernel also supports XZ compression, but as Guix does not have any available bindings for now, and the compression time is far more significant, GZIP seems to be a better option. * gnu/build/linux-modules.scm (modinfo-section-contents): Use 'call-with-gzip-input-port' to read from a module file using '.gz' extension, (strip-extension): new procedure, (dot-ko): adapt to support compression, (ensure-dot-ko): ditto, (file-name->module-name): ditto, (find-module-file): ditto, (load-linux-module*): ditto, (module-name->file-name/guess): ditto, (module-name-lookup): ditto, (write-module-name-database): ditto, (write-module-alias-database): ditto, (write-module-device-database): ditto. * gnu/installer.scm (installer-program): Add "guile-zlib" to the extensions. * gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto. * gnu/services.scm (activation-script): Ditto. * gnu/services/base.scm (default-serial-port): Ditto, (agetty-shepherd-service): ditto, (udev-service-type): ditto. * gnu/system/image.scm (gcrypt-sqlite3&co): Ditto. * gnu/system/linux-initrd.scm (flat-linux-module-directory): Add "guile-zlib" to the extensions and make sure that the initrd only contains uncompressed module files. * gnu/system/shadow.scm (account-shepherd-service): Add "guile-zlib" to the extensions. * guix/profiles.scm (linux-module-database): Ditto. --- gnu/build/linux-modules.scm | 115 ++++++++---- gnu/installer.scm | 3 +- gnu/machine/ssh.scm | 35 ++-- gnu/services.scm | 46 ++--- gnu/services/base.scm | 428 ++++++++++++++++++++++---------------------- gnu/system/image.scm | 2 +- gnu/system/linux-initrd.scm | 72 +++++--- gnu/system/shadow.scm | 12 +- guix/profiles.scm | 71 ++++---- 9 files changed, 433 insertions(+), 351 deletions(-) (limited to 'gnu/services') diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index aa1c7cfeae..3a47322065 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -24,6 +24,7 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (find-files invoke)) #:use-module (guix build union) + #:autoload (zlib) (call-with-gzip-input-port) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -94,10 +95,28 @@ string list." (cons (string->symbol (string-take str =)) (string-drop str (+ 1 =))))) +;; Matches kernel modules, without compression, with GZIP compression or with +;; XZ compression. +(define module-regex "\\.ko(\\.gz|\\.xz)?$") + (define (modinfo-section-contents file) "Return the contents of the '.modinfo' section of FILE as a list of key/value pairs.." - (let* ((bv (call-with-input-file file get-bytevector-all)) + (define (get-bytevector file) + (cond + ((string-suffix? ".ko.gz" file) + (let ((port (open-file file "r0"))) + (dynamic-wind + (lambda () + #t) + (lambda () + (call-with-gzip-input-port port get-bytevector-all)) + (lambda () + (close-port port))))) + (else + (call-with-input-file file get-bytevector-all)))) + + (let* ((bv (get-bytevector file)) (elf (parse-elf bv)) (section (elf-section-by-name elf ".modinfo")) (modinfo (section-contents elf section))) @@ -110,7 +129,7 @@ key/value pairs.." (define (module-formal-name file) "Return the module name of FILE as it appears in its info section. Usually the module name is the same as the base name of FILE, modulo hyphens and minus -the \".ko\" extension." +the \".ko[.gz|.xz]\" extension." (match (assq 'name (modinfo-section-contents file)) (('name . name) name) (#f #f))) @@ -171,14 +190,25 @@ modules that can be postloaded, of the soft dependencies of module FILE." (_ #f)) (modinfo-section-contents file)))) -(define dot-ko - (cut string-append <> ".ko")) - -(define (ensure-dot-ko name) - "Return NAME with a '.ko' prefix appended, unless it already has it." - (if (string-suffix? ".ko" name) +(define (strip-extension filename) + (let ((extension (string-index filename #\.))) + (if extension + (string-take filename extension) + filename))) + +(define (dot-ko name compression) + (let ((suffix (match compression + ('xz ".ko.xz") + ('gzip ".ko.gz") + (else ".ko")))) + (string-append name suffix))) + +(define (ensure-dot-ko name compression) + "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has +it." + (if (string-contains name ".ko") name - (dot-ko name))) + (dot-ko name compression))) (define (normalize-module-name module) "Return the \"canonical\" name for MODULE, replacing hyphens with @@ -191,9 +221,9 @@ underscores." module)) (define (file-name->module-name file) - "Return the module name corresponding to FILE, stripping the trailing '.ko' -and normalizing it." - (normalize-module-name (basename file ".ko"))) + "Return the module name corresponding to FILE, stripping the trailing +'.ko[.gz|.xz]' and normalizing it." + (normalize-module-name (strip-extension (basename file)))) (define (find-module-file directory module) "Lookup module NAME under DIRECTORY, and return its absolute file name. @@ -208,19 +238,19 @@ whereas file names often, but not always, use hyphens. Examples: ;; List of possible file names. XXX: It would of course be cleaner to ;; have a database that maps module names to file names and vice versa, ;; but everyone seems to be doing hacks like this one. Oh well! - (map ensure-dot-ko - (delete-duplicates - (list module - (normalize-module-name module) - (string-map (lambda (chr) ;converse of 'normalize-module-name' - (case chr - ((#\_) #\-) - (else chr))) - module))))) + (delete-duplicates + (list module + (normalize-module-name module) + (string-map (lambda (chr) ;converse of 'normalize-module-name' + (case chr + ((#\_) #\-) + (else chr))) + module)))) (match (find-files directory (lambda (file stat) - (member (basename file) names))) + (member (strip-extension + (basename file)) names))) ((file) file) (() @@ -290,8 +320,8 @@ not a file name." (recursive? #t) (lookup-module dot-ko) (black-list (module-black-list))) - "Load Linux module from FILE, the name of a '.ko' file; return true on -success, false otherwise. When RECURSIVE? is true, load its dependencies + "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true +on success, false otherwise. When RECURSIVE? is true, load its dependencies first (à la 'modprobe'.) The actual files containing modules depended on are obtained by calling LOOKUP-MODULE with the module name. Modules whose name appears in BLACK-LIST are not loaded." @@ -523,16 +553,29 @@ are required to access DEVICE." ;;; Module databases. ;;; -(define (module-name->file-name/guess directory name) +(define* (module-name->file-name/guess directory name + #:key compression) "Guess the file name corresponding to NAME, a module name. That doesn't always work because sometimes underscores in NAME map to hyphens (e.g., -\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")." - (string-append directory "/" (ensure-dot-ko name))) +\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is +compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the +compression type." + (string-append directory "/" (ensure-dot-ko name compression))) (define (module-name-lookup directory) "Return a one argument procedure that takes a module name (e.g., \"input_leds\") and returns its absolute file name (e.g., \"/.../input-leds.ko\")." + (define (guess-file-name name) + (let ((names (list + (module-name->file-name/guess directory name) + (module-name->file-name/guess directory name + #:compression 'xz) + (module-name->file-name/guess directory name + #:compression 'gzip)))) + (or (find file-exists? names) + (first names)))) + (catch 'system-error (lambda () (define mapping @@ -541,23 +584,23 @@ always work because sometimes underscores in NAME map to hyphens (e.g., (lambda (name) (or (assoc-ref mapping name) - (module-name->file-name/guess directory name)))) + (guess-file-name name)))) (lambda args (if (= ENOENT (system-error-errno args)) - (cut module-name->file-name/guess directory <>) + (cut guess-file-name <>) (apply throw args))))) (define (write-module-name-database directory) "Write a database that maps \"module names\" as they appear in the relevant -ELF section of '.ko' files, to actual file names. This format is +ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is Guix-specific. It aims to deal with inconsistent naming, in particular hyphens vs. underscores." (define mapping (map (lambda (file) (match (module-formal-name file) - (#f (cons (basename file ".ko") file)) + (#f (cons (strip-extension (basename file)) file)) (name (cons name file)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.name") (lambda (port) @@ -569,12 +612,12 @@ hyphens vs. underscores." (pretty-print mapping port)))) (define (write-module-alias-database directory) - "Traverse the '.ko' files in DIRECTORY and create the corresponding + "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding 'modules.alias' file." (define aliases (map (lambda (file) (cons (file-name->module-name file) (module-aliases file))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.alias") (lambda (port) @@ -616,7 +659,7 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f." (char-set-complement (char-set #\-))) (define (write-module-device-database directory) - "Traverse the '.ko' files in DIRECTORY and create the corresponding + "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding 'modules.devname' file. This file contains information about modules that can be loaded on-demand, such as file system modules." (define aliases @@ -624,7 +667,7 @@ be loaded on-demand, such as file system modules." (match (aliases->device-tuple (module-aliases file)) (#f #f) (tuple (cons (file-name->module-name file) tuple)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.devname") (lambda (port) diff --git a/gnu/installer.scm b/gnu/installer.scm index 5c3192d7a6..576ac90a4b 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,7 +342,8 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guix) + guile-json-3 guile-git guile-zlib + guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 4e31baa4b9..ee5032e281 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,6 +21,7 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) + #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -248,22 +249,24 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev '#$(operating-system-initrd-modules - (machine-operating-system machine))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev + '#$(operating-system-initrd-modules + (machine-operating-system machine)))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 11ba21e824..3e59c6401f 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,6 +35,7 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -585,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If it - ;; does not exist, 'setutxent' does not create it and - ;; thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things this - ;; sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If + ;; it does not exist, 'setutxent' does not create it + ;; and thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things + ;; this sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions)))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 491f35702a..966e7fe024 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,6 +50,7 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -836,36 +837,38 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name)))))))) + (with-extensions (list guile-zlib) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs + (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name))))))))) (define agetty-shepherd-service (match-lambda @@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) -;;; FIXME This doesn't work as expected. According to agetty(8), if this option -;;; is not passed, then the default is 'auto'. However, in my tests, when that -;;; option is selected, agetty never presents the login prompt, and the -;;; term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args))))) + (with-extensions (list guile-zlib) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this +;;; option is not passed, then the default is 'auto'. However, in my tests, +;;; when that option is selected, agetty never presents the login prompt, and +;;; the term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" + #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args)))))) (stop #~(make-kill-destructor))))))) (define agetty-service-type @@ -1939,70 +1944,73 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid (fork+exec-command (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/udev/rules.d")) - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid)))) + (with-extensions (list guile-zlib) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid + (fork+exec-command + (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/udev/rules.d")) + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid))))) (stop #~(make-kill-destructor)) ;; When halting the system, 'udev' is actually killed by diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 36f56e237d..19c99a3dfa 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3))) + (list guile-gcrypt guile-sqlite3 guile-zlib))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 0971ec29e2..b8a30c0abc 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to the initrd." (program-file "init" exp #:guile guile)) (define builder + ;; Do not use "guile-zlib" extension here, otherwise it would drag the + ;; non-static "zlib" package to the initrd closure. It is not needed + ;; anyway because the modules are stored uncompressed within the initrd. (with-imported-modules (source-module-closure '((gnu build linux-initrd))) #~(begin @@ -111,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd." (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." - (define build-exp - (with-imported-modules (source-module-closure - '((gnu build linux-modules))) - #~(begin - (use-modules (gnu build linux-modules) - (srfi srfi-1) - (srfi srfi-26)) - - (define module-dir - (string-append #$linux "/lib/modules")) + (define imported-modules + (source-module-closure '((gnu build linux-modules) + (guix build utils)))) - (define modules - (let* ((lookup (cut find-module-file module-dir <>)) - (modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) - - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules)) - - ;; Hyphen or underscore? This database tells us. - (write-module-name-database #$output)))) + (define build-exp + (with-imported-modules imported-modules + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build linux-modules) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (define modules + (let* ((lookup (cut find-module-file module-dir <>)) + (modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies + modules + #:lookup-module lookup)))) + + (define (maybe-uncompress file) + ;; If FILE is a compressed module, uncompress it, as the initrd + ;; is already gzipped as a whole. + (cond + ((string-contains file ".ko.gz") + (invoke #+(file-append gzip "/bin/gunzip") file)))) + + (mkdir #$output) + (for-each (lambda (module) + (let ((out-module + (string-append #$output "/" + (basename module)))) + (format #t "copying '~a'...~%" module) + (copy-file module out-module) + (maybe-uncompress out-module))) + (delete-duplicates modules)) + + ;; Hyphen or underscore? This database tells us. + (write-module-name-database #$output))))) (computed-file "linux-modules" build-exp)) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index a69339bc07..f642d250b0 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,6 +34,7 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -324,11 +325,12 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t))) ;success + (with-extensions (list guile-zlib) + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t)))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) diff --git a/guix/profiles.scm b/guix/profiles.scm index 6b2344270e..856a05eed1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel modules. This is meant to be used as a profile hook." (define kmod ; lazy reference (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - #~(begin - (use-modules (ice-9 ftw) - (ice-9 match) - (srfi srfi-1) ; append-map - (gnu build linux-modules)) - - (let* ((inputs '#$(manifest-inputs manifest)) - (module-directories - (map (lambda (directory) - (string-append directory "/lib/modules")) - inputs)) - (directory-entries - (lambda (directory) - (or (scandir directory - (lambda (basename) - (not (string-prefix? "." basename)))) - '()))) - ;; Note: Should usually result in one entry. - (versions (delete-duplicates - (append-map directory-entries - module-directories)))) - (match versions - ((version) - (let ((old-path (getenv "PATH"))) - (setenv "PATH" #+(file-append kmod "/bin")) - (make-linux-module-directory inputs version #$output) - (setenv "PATH" old-path))) - (() - ;; Nothing here, maybe because this is a kernel with - ;; CONFIG_MODULES=n. - (mkdir #$output)) - (_ (error "Specified Linux kernel and Linux kernel modules -are not all of the same version"))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) ; append-map + (gnu build linux-modules)) + + (let* ((inputs '#$(manifest-inputs manifest)) + (module-directories + (map (lambda (directory) + (string-append directory "/lib/modules")) + inputs)) + (directory-entries + (lambda (directory) + (or (scandir directory + (lambda (basename) + (not (string-prefix? "." basename)))) + '()))) + ;; Note: Should usually result in one entry. + (versions (delete-duplicates + (append-map directory-entries + module-directories)))) + (match versions + ((version) + (let ((old-path (getenv "PATH"))) + (setenv "PATH" #+(file-append kmod "/bin")) + (make-linux-module-directory inputs version #$output) + (setenv "PATH" old-path))) + (() + ;; Nothing here, maybe because this is a kernel with + ;; CONFIG_MODULES=n. + (mkdir #$output)) + (_ (error "Specified Linux kernel and Linux kernel modules +are not all of the same version")))))))) (gexp->derivation "linux-module-database" build #:local-build? #t #:substitutable? #f -- cgit v1.2.3 From dac7dd1b0b40c9f8c81b5147c68f6387c2b16bfd Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 25 Aug 2020 12:39:11 +0200 Subject: Remove "guile-zlib" extension when unused. This is a follow-up of 755f365b02b42a5d1e8ef3000dadef069553a478. As (zlib) is autoloaded in (gnu build linux-modules), "guile-zlib" is needed as an extension only when it is effectively used. * gnu/installer.scm (installer-program): Remove "guile-zlib" from the extensions. * gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto. * gnu/services.scm (activation-script): Ditto. * gnu/services/base.scm (default-serial-port): Ditto, (agetty-shepherd-service): ditto, (udev-service-type): ditto. * gnu/system/image.scm (gcrypt-sqlite3&co): Ditto. * gnu/system/shadow.scm (account-shepherd-service): Ditto. --- gnu/installer.scm | 3 +- gnu/machine/ssh.scm | 35 ++--- gnu/services.scm | 46 +++--- gnu/services/base.scm | 428 +++++++++++++++++++++++++------------------------- gnu/system/image.scm | 2 +- gnu/system/shadow.scm | 12 +- 6 files changed, 255 insertions(+), 271 deletions(-) (limited to 'gnu/services') diff --git a/gnu/installer.scm b/gnu/installer.scm index 576ac90a4b..5c3192d7a6 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,8 +342,7 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guile-zlib - guix) + guile-json-3 guile-git guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index ee5032e281..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,7 +21,6 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) - #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -249,24 +248,22 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev - '#$(operating-system-initrd-modules - (machine-operating-system machine)))))))) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev '#$(operating-system-initrd-modules + (machine-operating-system machine))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 3e59c6401f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,7 +35,6 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -586,29 +585,28 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If - ;; it does not exist, 'setutxent' does not create it - ;; and thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things - ;; this sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions)))))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 966e7fe024..491f35702a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,7 +50,6 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) - #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -837,38 +836,36 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - (with-extensions (list guile-zlib) - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs - (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name))))))))) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name)))))))) (define agetty-shepherd-service (match-lambda @@ -893,124 +890,122 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) -;;; FIXME This doesn't work as expected. According to agetty(8), if this -;;; option is not passed, then the default is 'auto'. However, in my tests, -;;; when that option is selected, agetty never presents the login prompt, and -;;; the term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" - #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args)))))) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this option +;;; is not passed, then the default is 'auto'. However, in my tests, when that +;;; option is selected, agetty never presents the login prompt, and the +;;; term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args))))) (stop #~(make-kill-destructor))))))) (define agetty-service-type @@ -1944,73 +1939,70 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid - (fork+exec-command - (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/udev/rules.d")) - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid))))) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid (fork+exec-command (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/udev/rules.d")) + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid)))) (stop #~(make-kill-destructor)) ;; When halting the system, 'udev' is actually killed by diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 19c99a3dfa..36f56e237d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3 guile-zlib))) + (list guile-gcrypt guile-sqlite3))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index f642d250b0..a69339bc07 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,7 +34,6 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -325,12 +324,11 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - (with-extensions (list guile-zlib) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t)))) ;success + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) -- cgit v1.2.3 From 2e832d4b8a1c68a9f28d5953819954ee37d9800f Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 25 Aug 2020 16:05:05 +0200 Subject: services: ganeti-kvmd-service-type: Fix typo in description. * gnu/services/ganeti.scm (ganeti-kvmd-service-type)[description]: Fix typo. --- gnu/services/ganeti.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/ganeti.scm b/gnu/services/ganeti.scm index 8d30472371..e2a2ec63e1 100644 --- a/gnu/services/ganeti.scm +++ b/gnu/services/ganeti.scm @@ -550,7 +550,7 @@ The KVM daemon monitors, using @code{inotify}, KVM instances through their QMP sockets, which are provided by KVM. Using the QMP sockets, the KVM daemon listens for particular shutdown, powerdown, and stop events which will determine if a given instance was shutdown by the user or Ganeti, and this result is -communicated to Ganeti via a special file in the filesystem."))) +communicated to Ganeti via a special file in the file system."))) (define-record-type* ganeti-mond-configuration make-ganeti-mond-configuration -- cgit v1.2.3 From 949672c923b6a3953471c446e0b19f30be335572 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Aug 2020 21:31:37 +0200 Subject: services: mcron: Validate jobs at build time. That way, run-time errors in the job specs are caught at build time. * gnu/services/mcron.scm (job-file): Remove. (job-files): New procedure. (mcron-shepherd-services): Adjust accordingly. --- gnu/services/mcron.scm | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index d9627c6bd0..045d6e2fe8 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -57,8 +57,26 @@ (jobs mcron-configuration-jobs ;list of (default '()))) -(define (job-file job) - (scheme-file "mcron-job" job)) +(define (job-files mcron jobs) + "Return a list of file-like object for JOBS, a list of gexps." + (define (validated-file job) + ;; This procedure behaves like 'scheme-file' but it runs 'mcron + ;; --schedule' to detect any error in JOB. + (computed-file "mcron-job" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (call-with-output-file "job" + (lambda (port) + (write '#$job port))) + + (invoke #+(file-append mcron "/bin/mcron") + "--schedule=20" "job") + (copy-file "job" #$output))) + #:options '(#:env-vars (("COLUMNS" . "150"))))) + + (map validated-file jobs)) (define (shepherd-schedule-action mcron files) "Return a Shepherd action that runs MCRON with '--schedule' for the given @@ -101,7 +119,7 @@ files." (($ mcron ()) ;nothing to do! '()) (($ mcron jobs) - (let ((files (map job-file jobs))) + (let ((files (job-files mcron jobs))) (list (shepherd-service (provision '(mcron)) (requirement '(user-processes)) -- cgit v1.2.3 From ef5ddb0e1715328713c2c9edad897f9a27de692f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 26 Aug 2020 15:30:04 +0200 Subject: services: mcron: Validate jobs even in the presence of #:user. Fixes a bug in 949672c923b6a3953471c446e0b19f30be335572 whereby jobs specifying a #:user not available in the build environment would fail validation. Reported by Maxim Cournoyer. * gnu/services/mcron.scm (job-files)[validated-file]: Add "prologue" file and pass it to 'mcron --schedule'. --- gnu/services/mcron.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index 045d6e2fe8..bd4e6e7410 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -67,12 +67,21 @@ #~(begin (use-modules (guix build utils)) + (call-with-output-file "prologue" + (lambda (port) + ;; This prologue allows 'mcron --schedule' to + ;; proceed no matter what #:user option is passed + ;; to 'job'. + (write '(set! getpw + (const (getpwuid (getuid)))) + port))) + (call-with-output-file "job" (lambda (port) (write '#$job port))) (invoke #+(file-append mcron "/bin/mcron") - "--schedule=20" "job") + "--schedule=20" "prologue" "job") (copy-file "job" #$output))) #:options '(#:env-vars (("COLUMNS" . "150"))))) -- cgit v1.2.3 From 17881f944e84b560dcc1537257e454f8de306001 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Tue, 18 Aug 2020 23:08:26 +0530 Subject: services: fcgiwrap: Create parent directory for unix socket. * gnu/services/web.scm (fcgiwrap-activation): New function. (fcgiwrap-service-type): Extend activation-service-type with fcgiwrap-activation. --- gnu/services/web.scm | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 3b9f9e40be..d11a1c0545 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -12,6 +12,7 @@ ;;; Copyright © 2019, 2020 Florian Pelz ;;; Copyright © 2020 Ricardo Wurmus ;;; Copyright © 2020 Tobias Geerinckx-Rice +;;; Copyright © 2020 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -794,13 +795,29 @@ of index files." #:user #$user #:group #$group)) (stop #~(make-kill-destructor))))))) +(define fcgiwrap-activation + (match-lambda + (($ package socket user group) + #~(begin + ;; When listening on a unix socket, create a parent directory for the + ;; socket with the correct permissions. + (when (string-prefix? "unix:" #$socket) + (let ((run-directory + (dirname (substring #$socket (string-length "unix:"))))) + (mkdir-p run-directory) + (chown run-directory + (passwd:uid (getpw #$user)) + (group:gid (getgr #$group))))))))) + (define fcgiwrap-service-type (service-type (name 'fcgiwrap) (extensions (list (service-extension shepherd-root-service-type fcgiwrap-shepherd-service) (service-extension account-service-type - fcgiwrap-accounts))) + fcgiwrap-accounts) + (service-extension activation-service-type + fcgiwrap-activation))) (default-value (fcgiwrap-configuration)))) (define-record-type* php-fpm-configuration -- cgit v1.2.3 From ec32d4f291b3cc039a99f8090b6c2b2444be5a83 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Sun, 30 Aug 2020 22:52:56 +0200 Subject: services: Add secret-service-type. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds a "secret-service" that can be added to a Childhurd VM to receive out-of-band secrets (keys) sent from the host. Co-authored-by: Ludovic Courtès * gnu/services/virtualization.scm (secret-service-activation): New procedure. (secret-service-type): New variable. * gnu/build/secret-service.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/build/secret-service.scm | 137 ++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/services/virtualization.scm | 29 ++++++++- 3 files changed, 166 insertions(+), 1 deletion(-) create mode 100644 gnu/build/secret-service.scm (limited to 'gnu/services') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm new file mode 100644 index 0000000000..781651e90d --- /dev/null +++ b/gnu/build/secret-service.scm @@ -0,0 +1,137 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 build secret-service) + #:use-module (guix build utils) + + #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + + #:export (secret-service-receive-secrets + secret-service-send-secrets)) + +;;; Commentary: +;;; +;;; Utility procedures for copying secrets into a VM. +;;; +;;; Code: + +(define* (secret-service-send-secrets port secret-root #:key (retry 60)) + "Copy all files under SECRET-ROOT using TCP to secret-service listening at +local PORT. If connect fails, sleep 1s and retry RETRY times." + + (define (file->file+size+mode file-name) + (let ((stat (stat file-name)) + (target (substring file-name (string-length secret-root)))) + (list target (stat:size stat) (stat:mode stat)))) + + (format (current-error-port) "sending secrets to ~a~%" port) + (let ((sock (socket AF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK port))) + ;; connect to wait for port + (let loop ((retry retry)) + (catch 'system-error + (cute connect sock addr) + (lambda (key . args) + (when (zero? retry) + (apply throw key args)) + (format (current-error-port) "retrying connection~%") + (sleep 1) + (loop (1- retry))))) + + (format (current-error-port) "connected! sending files in ~s %~" + secret-root) + (let* ((files (if secret-root (find-files secret-root) '())) + (files-sizes-modes (map file->file+size+mode files)) + (secrets `(secrets + (version 0) + (files ,files-sizes-modes)))) + (write secrets sock) + (for-each (compose (cute dump-port <> sock) + (cute open-input-file <>)) + files)))) + +(define (secret-service-receive-secrets port) + "Listen to local PORT and wait for a secret service client to send secrets. +Write them to the file system." + + (define (wait-for-client port) + ;; Wait for a TCP connection on PORT. Note: We cannot use the + ;; virtio-serial ports, which would be safer, because they are + ;; (presumably) unsupported on GNU/Hurd. + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (bind sock AF_INET INADDR_ANY port) + (listen sock 1) + (format (current-error-port) + "waiting for secrets on port ~a...~%" + port) + (match (accept sock) + ((client . address) + (format (current-error-port) "client connection from ~a~%" + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address))) + (close-port sock) + client)))) + + ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' + ;; parameter. + (define (dump in out size) + ;; Copy SIZE bytes from IN to OUT. + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + + (define (read-secrets port) + ;; Read secret files from PORT and install them. + (match (false-if-exception (read port)) + (('secrets ('version 0) + ('files ((files sizes modes) ...))) + (for-each (lambda (file size mode) + (format (current-error-port) + "installing file '~a' (~a bytes)...~%" + file size) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (output) + (dump port output size) + (chmod file mode)))) + files sizes modes)) + (_ + (format (current-error-port) + "invalid secrets received~%") + #f))) + + (let* ((port (wait-for-client port)) + (result (read-secrets port))) + (close-port port) + result)) + +;;; secret-service.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index 67cc13d35e..dfb9640b47 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -659,6 +659,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/linux-initrd.scm \ %D%/build/linux-modules.scm \ %D%/build/marionette.scm \ + %D%/build/secret-service.scm \ %D%/build/vm.scm \ \ %D%/tests.scm \ diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index b93ed70099..6d6734dcd1 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2020 Ludovic Courtès ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. @@ -804,6 +804,33 @@ given QEMU package." compiled for other architectures using QEMU and the @code{binfmt_misc} functionality of the kernel Linux."))) + +;;; +;;; Secrets for guest VMs. +;;; + +(define (secret-service-activation port) + "Return an activation snippet that fetches sensitive material at local PORT, +over TCP. Reboot upon failure." + (with-imported-modules '((gnu build secret-service) + (guix build utils)) + #~(begin + (use-modules (gnu build secret-service)) + (let ((sent (secret-service-receive-secrets #$port))) + (unless sent + (sleep 3) + (reboot)))))) + +(define secret-service-type + (service-type + (name 'secret-service) + (extensions (list (service-extension activation-service-type + secret-service-activation))) + (description + "This service fetches secret key and other sensitive material over TCP at +boot time. This service is meant to be used by virtual machines (VMs) that +can only be accessed by their host."))) + ;;; ;;; The Hurd in VM service: a Childhurd. -- cgit v1.2.3 From 01cefb7a570d846476ff5cb05d3b1e3511db5d81 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Sun, 30 Aug 2020 22:57:14 +0200 Subject: services: childhurd: Support installing secrets from the host. * gnu/services/virtualization.scm (%hurd-vm-operating-system): Add secret-service. (hurd-vm-shepherd-service): Use it to install secrets. * doc/guix.texi (The Hurd in a Virtual Machine): Document it. --- doc/guix.texi | 27 +++++++++++++++++++ gnu/services/virtualization.scm | 60 +++++++++++++++++++++++++++++++++-------- 2 files changed, 76 insertions(+), 11 deletions(-) (limited to 'gnu/services') diff --git a/doc/guix.texi b/doc/guix.texi index b1b0ab37d4..d3f0f729ec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25121,6 +25121,7 @@ Return the name of @var{platform}---a string such as @code{"arm"}. @cindex @code{hurd} @cindex the Hurd +@cindex childhurd Service @code{hurd-vm} provides support for running GNU/Hurd in a virtual machine (VM), a so-called ``Childhurd''. The virtual machine is @@ -25193,15 +25194,41 @@ By default, it produces @lisp '("--device" "rtl8139,netdev=net0" "--netdev" "user,id=net0\ + ,hostfwd=tcp:127.0.0.1:-:1004\ ,hostfwd=tcp:127.0.0.1:-:2222\ ,hostfwd=tcp:127.0.0.1:-:5900") @end lisp with forwarded ports @example +: @code{(+ 11004 (* 1000 @var{ID}))} : @code{(+ 10022 (* 1000 @var{ID}))} : @code{(+ 15900 (* 1000 @var{ID}))} @end example +@item @code{secret-root} (default: @file{/etc/childhurd}) +The root directory with out-of-band secrets to be installed into the +childhurd once it runs. Childhurds are volatile which means that on +every startup, secrets such as the SSH host keys and Guix signing key +are recreated. + +If the @file{/etc/childhurd} directory does not exist, the +@code{secret-service} running in the Childhurd will be sent an empty +list of secrets. + +Typical use to populate @file{"/etc/childhurd"} with a tree of +non-volatile secrets, like so + +@example +/etc/childhurd/etc/guix/signing-key.pub +/etc/childhurd/etc/guix/signing-key.sec +/etc/childhurd/etc/ssh/ssh_host_ed25519_key +/etc/childhurd/etc/ssh/ssh_host_ecdsa_key +/etc/childhurd/etc/ssh/ssh_host_ed25519_key.pub +/etc/childhurd/etc/ssh/ssh_host_ecdsa_key.pub +@end example + +to be sent to the Childhurd, including permissions. + @end table @end deftp diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 6d6734dcd1..75fe203e15 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -39,6 +39,7 @@ #:use-module (gnu system) #:use-module (guix derivations) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix records) @@ -61,7 +62,10 @@ hurd-vm-configuration-options hurd-vm-configuration-id hurd-vm-configuration-net-options + hurd-vm-configuration-secrets + hurd-vm-disk-image + hurd-vm-port hurd-vm-net-options hurd-vm-service-type @@ -846,6 +850,8 @@ can only be accessed by their host."))) (target "/dev/vda") (timeout 0))) (services (cons* + ;; Receive secret keys on port 1004, TCP. + (service secret-service-type 1004) (service openssh-service-type (openssh-configuration (openssh openssh-sans-x) @@ -876,7 +882,9 @@ can only be accessed by their host."))) (default #f)) (net-options hurd-vm-configuration-net-options ;list of string (thunked) - (default (hurd-vm-net-options this-record)))) + (default (hurd-vm-net-options this-record))) + (secret-root hurd-vm-configuration-secret-root ;string + (default "/etc/childhurd"))) (define (hurd-vm-disk-image config) "Return a disk-image for the Hurd according to CONFIG." @@ -888,15 +896,27 @@ can only be accessed by their host."))) (size disk-size) (operating-system os))))) -(define (hurd-vm-net-options config) +(define (hurd-vm-port config base) + "Return the forwarded vm port for this childhurd config." (let ((id (or (hurd-vm-configuration-id config) 0))) - (define (qemu-vm-port base) - (number->string (+ base (* 1000 id)))) - `("--device" "rtl8139,netdev=net0" - "--netdev" ,(string-append - "user,id=net0" - ",hostfwd=tcp:127.0.0.1:" (qemu-vm-port 10022) "-:2222" - ",hostfwd=tcp:127.0.0.1:" (qemu-vm-port 15900) "-:5900")))) + (+ base (* 1000 id)))) +(define %hurd-vm-secrets-port 11004) +(define %hurd-vm-ssh-port 10022) +(define %hurd-vm-vnc-port 15900) + +(define (hurd-vm-net-options config) + `("--device" "rtl8139,netdev=net0" + "--netdev" + ,(string-append "user,id=net0" + ",hostfwd=tcp:127.0.0.1:" + (number->string (hurd-vm-port config %hurd-vm-secrets-port)) + "-:1004" + ",hostfwd=tcp:127.0.0.1:" + (number->string (hurd-vm-port config %hurd-vm-ssh-port)) + "-:2222" + ",hostfwd=tcp:127.0.0.1:" + (number->string (hurd-vm-port config %hurd-vm-vnc-port)) + "-:5900"))) (define (hurd-vm-shepherd-service config) "Return a for a Hurd in a Virtual Machine with CONFIG." @@ -927,8 +947,26 @@ can only be accessed by their host."))) (string->symbol (number->string id))) provisions) provisions)) - (requirement '(networking)) - (start #~(make-forkexec-constructor #$vm-command)) + (requirement '(loopback networking user-processes)) + (start + (with-imported-modules + (source-module-closure '((gnu build secret-service) + (guix build utils))) + #~(let ((spawn (make-forkexec-constructor #$vm-command))) + (lambda _ + (let ((pid (spawn)) + (port #$(hurd-vm-port config %hurd-vm-secrets-port)) + (root #$(hurd-vm-configuration-secret-root config))) + (catch #t + (lambda _ + (secret-service-send-secrets port root)) + (lambda (key . args) + (kill (- pid) SIGTERM) + (apply throw key args))) + pid))))) + (modules `((gnu build secret-service) + (guix build utils) + ,@%default-modules)) (stop #~(make-kill-destructor)))))) (define hurd-vm-service-type -- cgit v1.2.3 From 18a9c16b5e067c9737452eb014ab80b5d1ffb915 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Wed, 2 Sep 2020 07:13:15 +0200 Subject: services: childhurd: Always include the secret-service. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/virtualization.scm (secret-service-operating-system): New procedure. (hurd-vm-disk-image): Use it to ensure a Childhurd always includes the secret-service. (%hurd-vm-operating-system): Remove secret-service. Co-authored-by: Ludovic Courtès --- gnu/services/virtualization.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'gnu/services') diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 75fe203e15..20e104f48c 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -835,6 +835,14 @@ over TCP. Reboot upon failure." boot time. This service is meant to be used by virtual machines (VMs) that can only be accessed by their host."))) +(define (secret-service-operating-system os) + "Return an operating system based on OS that includes the secret-service, +that will be listening to receive secret keys on port 1004, TCP." + (operating-system + (inherit os) + (services (cons (service secret-service-type 1004) + (operating-system-user-services os))))) + ;;; ;;; The Hurd in VM service: a Childhurd. @@ -850,8 +858,6 @@ can only be accessed by their host."))) (target "/dev/vda") (timeout 0))) (services (cons* - ;; Receive secret keys on port 1004, TCP. - (service secret-service-type 1004) (service openssh-service-type (openssh-configuration (openssh openssh-sans-x) @@ -887,8 +893,9 @@ can only be accessed by their host."))) (default "/etc/childhurd"))) (define (hurd-vm-disk-image config) - "Return a disk-image for the Hurd according to CONFIG." - (let ((os (hurd-vm-configuration-os config)) + "Return a disk-image for the Hurd according to CONFIG. The secret-service +is added to the OS specified in CONFIG." + (let ((os (secret-service-operating-system (hurd-vm-configuration-os config))) (disk-size (hurd-vm-configuration-disk-size config))) (system-image (image -- cgit v1.2.3 From 8ce6f4dc2879919c12bc76a2f4b01200af97e019 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 13 Aug 2020 14:16:12 +0200 Subject: installer: Run the installation inside a container. When the store overlay is mounted, other processes such as kmscon, udev and guix-daemon may open files from the store, preventing the underlying install support from being umounted. See: https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. To avoid this situation, mount the store overlay inside a container, and run the installation from within that container. * gnu/build/shepherd.scm (fork+exec-command/container): New procedure. * gnu/services/base.scm (guix-shepherd-service): Support an optional PID argument passed to the "start" method. If that argument is passed, ensure that guix-daemon enters the given PID MNT namespace by using fork+exec-command/container procedure. * gnu/installer/final.scm (umount-cow-store): Remove it, (install-system): run the installation from within a container. * gnu/installer/newt/final.scm (run-install-shell): Remove the display hack. --- gnu/build/shepherd.scm | 18 ++++++- gnu/installer/final.scm | 124 +++++++++++++++++++++---------------------- gnu/installer/newt/final.scm | 7 --- gnu/services/base.scm | 115 ++++++++++++++++++++++----------------- 4 files changed, 142 insertions(+), 122 deletions(-) (limited to 'gnu/services') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index fd93e7f3f4..65141bd60f 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -20,10 +20,12 @@ #:use-module (gnu system file-systems) #:use-module (gnu build linux-container) #:use-module (guix build utils) + #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (make-forkexec-constructor/container)) + #:export (make-forkexec-constructor/container + fork+exec-command/container)) ;;; Commentary: ;;; @@ -93,7 +95,8 @@ ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. (module-autoload! (current-module) '(shepherd service) - '(read-pid-file exec-command %precious-signals)) + '(fork+exec-command read-pid-file exec-command + %precious-signals)) (module-autoload! (current-module) '(shepherd system) '(unblock-signals)) @@ -188,6 +191,17 @@ namespace, in addition to essential bind-mounts such /proc." (read-pid-file pid-file #:max-delay pid-file-timeout)) pid)))) +(define* (fork+exec-command/container command + #:key pid + #:allow-other-keys + #:rest args) + "This is a variant of 'fork+exec-command' procedure, that joins the +namespaces of process PID beforehand." + (container-excursion* pid + (lambda () + (apply fork+exec-command command + (strip-keyword-arguments '(#:pid) args))))) + ;; Local Variables: ;; eval: (put 'container-excursion* 'scheme-indent-function 1) ;; End: diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm index 685aa81d89..11143b2adb 100644 --- a/gnu/installer/final.scm +++ b/gnu/installer/final.scm @@ -26,6 +26,8 @@ #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (gnu build accounts) + #:use-module (gnu build install) + #:use-module (gnu build linux-container) #:use-module ((gnu system shadow) #:prefix sys:) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -133,49 +135,18 @@ USERS." (_ #f)))))) pids))) -(define (umount-cow-store) - "Remove the store overlay and the bind-mount on /tmp created by the -cow-store service. This procedure is very fragile and a better approach would -be much appreciated." - (catch #t - (lambda () - (let ((tmp-dir "/remove")) - (syslog "Unmounting cow-store.~%") - - (mkdir-p tmp-dir) - (mount (%store-directory) tmp-dir "" MS_MOVE) - - ;; The guix-daemon has possibly opened files from the cow-store, - ;; restart it. - (restart-service 'guix-daemon) - - (syslog "Killing cow users.") - - ;; Kill all processes started while the cow-store was active (logins - ;; on other TTYs for instance). - (kill-cow-users tmp-dir) - - ;; Try to umount the store overlay. Some process such as udevd - ;; workers might still be active, so do some retries. - (let loop ((try 5)) - (syslog "Umount try ~a~%" (- 5 try)) - (sleep 1) - (let ((umounted? (false-if-exception (umount tmp-dir)))) - (if (and (not umounted?) (> try 0)) - (loop (- try 1)) - (if umounted? - (syslog "Umounted ~a successfully.~%" tmp-dir) - (syslog "Failed to umount ~a.~%" tmp-dir))))) - - (umount "/tmp"))) - (lambda args - (syslog "~a~%" args)))) - (define* (install-system locale #:key (users '())) "Create /etc/shadow and /etc/passwd on the installation target for USERS. Start COW-STORE service on target directory and launch guix install command in a subshell. LOCALE must be the locale name under which that command will run, or #f. Return #t on success and #f on failure." + (define backing-directory + ;; Sub-directory used as the backing store for copy-on-write. + "/tmp/guix-inst") + + (define (assert-exit x) + (primitive-exit (if x 0 1))) + (let* ((options (catch 'system-error (lambda () ;; If this file exists, it can provide @@ -188,7 +159,11 @@ or #f. Return #t on success and #f on failure." "--fallback") options (list (%installer-configuration-file) - (%installer-target-dir))))) + (%installer-target-dir)))) + (database-dir "/var/guix/db") + (database-file (string-append database-dir "/db.sqlite")) + (saved-database (string-append database-dir "/db.save")) + (ret #f)) (mkdir-p (%installer-target-dir)) ;; We want to initialize user passwords but we don't want to store them in @@ -198,27 +173,50 @@ or #f. Return #t on success and #f on failure." ;; passwords that we've put in there. (create-user-database users (%installer-target-dir)) - (dynamic-wind - (lambda () - (start-service 'cow-store (list (%installer-target-dir)))) - (lambda () - ;; If there are any connected clients, assume that we are running - ;; installation tests. In that case, dump the standard and error - ;; outputs to syslog. - (if (not (null? (current-clients))) - (with-output-to-file "/dev/console" - (lambda () - (with-error-to-file "/dev/console" - (lambda () - (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) 'none) - (run-command install-command #:locale locale))))) - (run-command install-command #:locale locale))) - (lambda () - (stop-service 'cow-store) - ;; Remove the store overlay created at cow-store service start. - ;; Failing to do that will result in further umount calls to fail - ;; because the target device is seen as busy. See: - ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. - (umount-cow-store) - #f)))) + ;; When the store overlay is mounted, other processes such as kmscon, udev + ;; and guix-daemon may open files from the store, preventing the + ;; underlying install support from being umounted. See: + ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. + ;; + ;; To avoid this situation, mount the store overlay inside a container, + ;; and run the installation from within that container. + (zero? + (call-with-container '() + (lambda () + (dynamic-wind + (lambda () + ;; Save the database, so that it can be restored once the + ;; cow-store is umounted. + (copy-file database-file saved-database) + (mount-cow-store (%installer-target-dir) backing-directory)) + (lambda () + ;; We need to drag the guix-daemon to the container MNT + ;; namespace, so that it can operate on the cow-store. + (stop-service 'guix-daemon) + (start-service 'guix-daemon (list (number->string (getpid)))) + + (setvbuf (current-output-port) 'none) + (setvbuf (current-error-port) 'none) + + ;; If there are any connected clients, assume that we are running + ;; installation tests. In that case, dump the standard and error + ;; outputs to syslog. + (set! ret + (if (not (null? (current-clients))) + (with-output-to-file "/dev/console" + (lambda () + (with-error-to-file "/dev/console" + (lambda () + (run-command install-command + #:locale locale))))) + (run-command install-command #:locale locale)))) + (lambda () + ;; Restart guix-daemon so that it does no keep the MNT namespace + ;; alive. + (restart-service 'guix-daemon) + (copy-file saved-database database-file) + + ;; Finally umount the cow-store and exit the container. + (unmount-cow-store (%installer-target-dir) backing-directory) + (assert-exit ret)))) + #:namespaces '(mnt))))) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index fa8d6fea71..89684c4d8a 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -102,13 +102,6 @@ a specific step, or restart the installer.")) #:key (users '())) (clear-screen) (newt-suspend) - ;; XXX: Force loading 'bold' font files before mouting the - ;; cow-store. Otherwise, if the file is loaded by kmscon after the cow-store - ;; in mounted, it will be necessary to kill kmscon to umount to cow-store. - (display - (colorize-string - (format #f (G_ "Installing Guix System ...~%")) - (color BOLD))) (let ((install-ok? (install-system locale #:users users))) (newt-resume) install-ok?)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 491f35702a..d560ad5a13 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1558,57 +1558,72 @@ proxy of 'guix-daemon'...~%") (provision '(guix-daemon)) (requirement '(user-processes)) (actions (list shepherd-set-http-proxy-action)) - (modules '((srfi srfi-1))) + (modules '((srfi srfi-1) + (ice-9 match) + (gnu build shepherd))) (start - #~(lambda _ - (define proxy - ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by - ;; the 'set-http-proxy' action. - (or (getenv "http_proxy") #$http-proxy)) - - (fork+exec-command - (cons* #$(file-append guix "/bin/guix-daemon") - "--build-users-group" #$build-group - "--max-silent-time" #$(number->string max-silent-time) - "--timeout" #$(number->string timeout) - "--log-compression" #$(symbol->string log-compression) - #$@(if use-substitutes? - '() - '("--no-substitutes")) - "--substitute-urls" #$(string-join substitute-urls) - #$@extra-options - - ;; Add CHROOT-DIRECTORIES and all their dependencies - ;; (if these are store items) to the chroot. - (append-map (lambda (file) - (append-map (lambda (directory) - (list "--chroot-directory" - directory)) - (call-with-input-file file - read))) - '#$(map references-file - chroot-directories))) - - #:environment-variables - (append (list #$@(if tmpdir - (list (string-append "TMPDIR=" tmpdir)) - '()) - - ;; Make sure we run in a UTF-8 locale so that - ;; 'guix offload' correctly restores nars that - ;; contain UTF-8 file names such as - ;; 'nss-certs'. See - ;; . - (string-append "GUIX_LOCPATH=" - #$glibc-utf8-locales - "/lib/locale") - "LC_ALL=en_US.utf8") - (if proxy - (list (string-append "http_proxy=" proxy) - (string-append "https_proxy=" proxy)) - '())) - - #:log-file #$log-file))) + (with-imported-modules (source-module-closure + '((gnu build shepherd))) + #~(lambda args + (define proxy + ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by + ;; the 'set-http-proxy' action. + (or (getenv "http_proxy") #$http-proxy)) + + (fork+exec-command/container + (cons* #$(file-append guix "/bin/guix-daemon") + "--build-users-group" #$build-group + "--max-silent-time" + #$(number->string max-silent-time) + "--timeout" #$(number->string timeout) + "--log-compression" + #$(symbol->string log-compression) + #$@(if use-substitutes? + '() + '("--no-substitutes")) + "--substitute-urls" #$(string-join substitute-urls) + #$@extra-options + + ;; Add CHROOT-DIRECTORIES and all their dependencies + ;; (if these are store items) to the chroot. + (append-map + (lambda (file) + (append-map (lambda (directory) + (list "--chroot-directory" + directory)) + (call-with-input-file file + read))) + '#$(map references-file + chroot-directories))) + + ;; When running the installer, we need guix-daemon to + ;; operate from within the same MNT namespace as the + ;; installation container. In that case only, enter the + ;; namespace of the process PID passed as start argument. + #:pid (match args + ((pid) (string->number pid)) + (else (getpid))) + + #:environment-variables + (append (list #$@(if tmpdir + (list (string-append "TMPDIR=" tmpdir)) + '()) + + ;; Make sure we run in a UTF-8 locale so that + ;; 'guix offload' correctly restores nars + ;; that contain UTF-8 file names such as + ;; 'nss-certs'. See + ;; . + (string-append "GUIX_LOCPATH=" + #$glibc-utf8-locales + "/lib/locale") + "LC_ALL=en_US.utf8") + (if proxy + (list (string-append "http_proxy=" proxy) + (string-append "https_proxy=" proxy)) + '())) + + #:log-file #$log-file)))) (stop #~(make-kill-destructor)))))) (define (guix-accounts config) -- cgit v1.2.3