From 9c7581a1273d049a95c0fa4f52fe29ec9145d101 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jul 2020 16:04:05 +0200 Subject: doc: Use an existing commit in channel example. Suggested by zimoun . * doc/guix.texi (Channels): Use the commit for 'v1.0.0' instead of a non-existing commit in example. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index fb1c66dcf4..0d090eef18 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4379,7 +4379,7 @@ say, on another machine, by providing a channel specification in (list (channel (name 'guix) (url "https://git.savannah.gnu.org/git/guix.git") - (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300")) + (commit "6298c3ffd9654d3231a6f25390b056483e8f407c")) (channel (name 'my-personal-packages) (url "https://example.org/personal-packages.git") -- cgit v1.2.3 From cb3bae900f6c85d4529842bf75f3cca0b4bb1df7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jul 2020 17:44:20 +0200 Subject: doc: Mention the channel keyring branch. Reported by Pierre Neidhardt . * doc/guix.texi (Channels): Mention the keyring branch and the 'keyring-reference' bit in '.guix-channel'. --- doc/guix.texi | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 0d090eef18..a6fc64bed8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4245,10 +4245,28 @@ time-machine}, the command looks up the introductory commit and verifies that it is signed by the specified OpenPGP key. From then on, it authenticates commits according to the rule above. -To summarize, as the author of a channel, there are two things you have +Additionally, your channel must provide all the OpenPGP keys that were +ever mentioned in @file{.guix-authorizations}, stored as @file{.key} +files, which can be either binary or ``ASCII-armored''. By default, +those @file{.key} files are searched for in the branch named +@code{keyring} but you can specify a different branch name in +@code{.guix-channel} like so: + +@lisp +(channel + (version 0) + (keyring-reference "my-keyring-branch")) +@end lisp + +To summarize, as the author of a channel, there are three things you have to do to allow users to authenticate your code: @enumerate +@item +Export the OpenPGP keys of past and present committers with @command{gpg +--export} and store them in @file{.key} files, by default in a branch +named @code{keyring} (we recommend making it an @dfn{orphan branch}). + @item Introduce an initial @file{.guix-authorizations} in the channel's repository. Do that in a signed commit (@pxref{Commit Access}, for -- 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 'doc/guix.texi') 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 @@ (define-record-type* (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 @@ (define nix-activation '#$(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 a396dd01bc6e90ae512001350d1afa471e01661d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jul 2020 11:03:14 +0200 Subject: machine: ssh: Check for potential system downgrades. This is a followup to 8e31736b0a60919cc1bfc5dc22c395b09243484a. * guix/scripts/system/reconfigure.scm (check-forward-update): Add #:current-channels. Use it instead of OLD. * gnu/services.scm (sexp->system-provenance): New procedure. (system-provenance): Use it. * gnu/machine/ssh.scm ()[allow-downgrades?]: New field. (machine-check-forward-update): New procedure. (check-deployment-sanity)[assertions]: Call it. * doc/guix.texi (Invoking guix deploy): Document 'allow-downgrades?' field. --- doc/guix.texi | 10 ++++++++++ gnu/machine/ssh.scm | 32 +++++++++++++++++++++++++++++++- gnu/services.scm | 26 +++++++++++++++++--------- guix/scripts/system/reconfigure.scm | 21 +++++++++++---------- 4 files changed, 69 insertions(+), 20 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index e2b304ff63..ca96ecc298 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -29033,6 +29033,16 @@ When @code{host-key} is @code{#f}, the server is authenticated against the @file{~/.ssh/known_hosts} file, just like the OpenSSH @command{ssh} client does. +@item @code{allow-downgrades?} (default: @code{#f}) +Whether to allow potential downgrades. + +Like @command{guix system reconfigure}, @command{guix deploy} compares +the channel commits currently deployed on the remote host (as returned +by @command{guix system describe}) to those currently in use (as +returned by @command{guix describe}) to determine whether commits +currently in use are descendants of those deployed. When this is not +the case and @code{allow-downgrades?} is false, it raises an error. +This ensures you do not accidentally downgrade remote machines. @end table @end deftp diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 641e871861..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -24,6 +24,7 @@ (define-module (gnu machine ssh) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) + #:use-module ((gnu services) #:select (sexp->system-provenance)) #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix i18n) @@ -55,6 +56,7 @@ (define-module (gnu machine ssh) machine-ssh-configuration-host-name machine-ssh-configuration-build-locally? machine-ssh-configuration-authorize? + machine-ssh-configuration-allow-downgrades? machine-ssh-configuration-port machine-ssh-configuration-user machine-ssh-configuration-host-key @@ -83,6 +85,8 @@ (define-record-type* machine-ssh-configuration (default #t)) (authorize? machine-ssh-configuration-authorize? ; boolean (default #t)) + (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean + (default #f)) (port machine-ssh-configuration-port ; integer (default 22)) (user machine-ssh-configuration-user ; string @@ -271,6 +275,27 @@ (define dev (map missing-modules file-systems)) +(define* (machine-check-forward-update machine) + "Check whether we are making a forward update for MACHINE. Depending on its +'allow-upgrades?' field, raise an error or display a warning if we are +potentially downgrading it." + (define config + (machine-configuration machine)) + + (define validate-reconfigure + (if (machine-ssh-configuration-allow-downgrades? config) + warn-about-backward-reconfigure + ensure-forward-reconfigure)) + + (remote-let ((provenance #~(call-with-input-file + "/run/current-system/provenance" + read))) + (define channels + (sexp->system-provenance provenance)) + + (check-forward-update validate-reconfigure + #:current-channels channels))) + (define (machine-check-building-for-appropriate-system machine) "Raise a '&message' error condition if MACHINE is configured to be built locally and the 'system' field does not match the '%current-system' reported @@ -289,7 +314,8 @@ (define (check-deployment-sanity machine) 'system' declaration would fail." (define assertions (append (machine-check-file-system-availability machine) - (machine-check-initrd-modules machine))) + (machine-check-initrd-modules machine) + (list (machine-check-forward-update machine)))) (define aggregate-exp ;; Gather all the expressions so that a single round-trip is enough to @@ -491,3 +517,7 @@ (define (maybe-raise-unsupported-configuration-error machine) for environment of type '~a'") config environment))))) + +;; Local Variables: +;; eval: (put 'remote-let 'scheme-indent-function 1) +;; End: diff --git a/gnu/services.scm b/gnu/services.scm index 399a432e3f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -89,6 +89,7 @@ (define-module (gnu services) system-service-type provenance-service-type + sexp->system-provenance system-provenance boot-service-type cleanup-service-type @@ -488,6 +489,19 @@ (define provenance-service-type itself: the channels used when building the system, and its configuration file, when available."))) +(define (sexp->system-provenance sexp) + "Parse SEXP, an s-expression read from /run/current-system/provenance or +similar, and return two values: the list of channels listed therein, and the +OS configuration file or #f." + (match sexp + (('provenance ('version 0) + ('channels channels ...) + ('configuration-file config-file)) + (values (map sexp->channel channels) + config-file)) + (_ + (values '() #f)))) + (define (system-provenance system) "Given SYSTEM, the file name of a system generation, return two values: the list of channels SYSTEM is built from, and its configuration file. If that @@ -495,15 +509,9 @@ (define (system-provenance system) #false (for the configuration file)." (catch 'system-error (lambda () - (match (call-with-input-file (string-append system "/provenance") - read) - (('provenance ('version 0) - ('channels channels ...) - ('configuration-file config-file)) - (values (map sexp->channel channels) - config-file)) - (_ - (values '() #f)))) + (sexp->system-provenance + (call-with-input-file (string-append system "/provenance") + read))) (lambda _ (values '() #f)))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index a2570839a8..45bb1d5d3b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -339,24 +339,25 @@ (define (channel-relations old new) old)) (define* (check-forward-update #:optional - (validate-reconfigure ensure-forward-reconfigure)) + (validate-reconfigure + ensure-forward-reconfigure) + #:key + (current-channels + (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the -currently-deployed commit (as returned by 'guix system describe') and the -target commit (as returned by 'guix describe')." - ;; TODO: Make that functionality available to 'guix deploy'. +currently-deployed commit (from CURRENT-CHANNELS, which is as returned by +'guix system describe' by default) and the target commit (as returned by 'guix +describe')." (define new (or (and=> (current-profile) profile-channels) '())) - (define old - (system-provenance "/run/current-system")) - - (when (null? old) - (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (null? current-channels) + (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) - (channel-relations old new))) + (channel-relations current-channels new))) -- 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 'doc/guix.texi') 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 @@ (define-module (gnu services admin) 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 @@ (define rottlog-service-type 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 'doc/guix.texi') 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 @@ (define-module (gnu services auditd) #: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 64e8f2ec2dc6301019a5b93a82787ea6adaf8c76 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Tue, 14 Jul 2020 10:46:44 +0200 Subject: doc: Warn against using the .scm extension for the channel news file. * doc/guix.texi (Writing Channel News): Explain the issue with using the .scm extension and possible workarounds; fix the example to use the .txt extension instead. --- doc/guix.texi | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index d4557b360a..74c7417174 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4358,6 +4358,12 @@ something like this: (body (en "Don't miss the @@code@{hello@} package!")))) @end lisp +While the news file is using the Scheme syntax, avoid naming it with a +@file{.scm} extension or else it will get picked up when building the +channel and yield an error since it is not a valid module. +Alternatively, you can move the channel module to a subdirectory and +store the news file in another directory. + The file consists of a list of @dfn{news entries}. Each entry is associated with a commit or tag: it describes changes made in this commit, possibly in preceding commits as well. Users see entries only @@ -4376,7 +4382,7 @@ you write news entries in English first, the command below creates a PO file containing the strings to translate: @example -xgettext -o news.po -l scheme -ken etc/news.scm +xgettext -o news.po -l scheme -ken etc/news.txt @end example To sum up, yes, you could use your channel as a blog. But beware, this -- cgit v1.2.3 From cdc2e2bba959ec3afa7de6f9a867c862982e079a Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Fri, 24 Jul 2020 11:57:43 +0200 Subject: doc: Extend tlp-service-type example. * doc/guix.texi (Power Management Services): Demonstrate tlp-configuration usage. Suggested by rovanion on #guix. --- doc/guix.texi | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 74c7417174..b2030e68cf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -23626,17 +23626,17 @@ source is detected. More information can be found at @uref{https://linrunner.de/en/tlp/tlp.html, TLP home page}. @deffn {Scheme Variable} tlp-service-type -The service type for the TLP tool. Its value should be a valid -TLP configuration (see below). To use the default settings, simply -write: +The service type for the TLP tool. The default settings are optimised +for battery life on most systems, but you can tweak them to your heart's +content by adding a valid @code{tlp-configuration}: @lisp -(service tlp-service-type) +(service tlp-service-type + (tlp-configuration + (cpu-scaling-governor-on-ac (list "performance")) + (sched-powersave-on-bat? #t))) @end lisp @end deffn -By default TLP does not need much configuration but most TLP parameters -can be tweaked using @code{tlp-configuration}. - Each parameter definition is preceded by its type; for example, @samp{boolean foo} indicates that the @code{foo} parameter should be specified as a boolean. Types starting with -- cgit v1.2.3 From 1f0a41e95505c12af17c416651d70f18ea7c6a07 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Wed, 10 Jun 2020 11:29:04 +0200 Subject: doc: Explain how to use psql with peer authentication. * doc/guix.texi (Database Services): Add example of shell commands to use psql as system user. Also add troubleshooting tip when service fails to start because of incompatible cluster. --- doc/guix.texi | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index b2030e68cf..c23ed8d715 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -17260,6 +17260,24 @@ The PostgreSQL daemon loads its runtime configuration from @var{config-file}, creates a database cluster with @var{locale} as the default locale, stored in @var{data-directory}. It then listens on @var{port}. +If the services fails to start, it may be due to an incompatible +cluster already present in @var{data-directory}. Adjust it (or, if you +don't need the cluster anymore, delete @var{data-directory}), then +restart the service. + +Peer authentication is used by default and the @code{postgres} user +account has no shell, which prevents the direct execution of @code{psql} +commands as this user. To use @code{psql}, you can temporarily log in +as @code{postgres} using a shell, create a PostgreSQL superuser with the +same name as one of the system users and then create the associated +database. + +@example +sudo -u postgres -s /bin/sh +createuser --interactive +createdb $MY_USER_LOGIN # Replace appropriately. +@end example + @cindex postgresql extension-packages Additional extensions are loaded from packages listed in @var{extension-packages}. Extensions are available at runtime. For instance, -- 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 'doc/guix.texi') 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 @@ (define-module (gnu services linux) #: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 @@ (define-module (gnu services linux) 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 @@ (define kernel-module-loader-service-type (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 @@ (define %earlyoom-configuration-sample "-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 c471d4733f066f70e8ec9997e96c0096758aac29 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Aug 2020 17:14:54 +0200 Subject: doc: Document 'mount-may-fail?' field. This is a followup to 7c27bd115b14afd142da7684cc349369965f9eab. * doc/guix.texi (File Systems): Document 'mount-may-fail?'. --- doc/guix.texi | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index f9cb7f204b..0c8c284a84 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12165,6 +12165,12 @@ errors before being mounted. @item @code{create-mount-point?} (default: @code{#f}) When true, the mount point is created if it does not exist yet. +@item @code{mount-may-fail?} (default: @code{#f}) +When true, this indicates that mounting this file system can fail but +that should not be considered an error. This is useful in unusual +cases; an example of this is @code{efivarfs}, a file system that can +only be mounted on EFI/UEFI systems. + @item @code{dependencies} (default: @code{'()}) This is a list of @code{} or @code{} objects representing file systems that must be mounted or mapped devices that -- cgit v1.2.3 From 3de419b957e7ce4c294aaa09d94a0cc8779723e7 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 9 Aug 2020 17:38:38 +0200 Subject: doc: Fix typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi (operating-system Reference): Add missing ‘of’. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 0c8c284a84..4b13d4a00e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11944,7 +11944,7 @@ If the @code{users} list lacks a user account with UID@tie{}0, a ``root'' account with UID@tie{}0 is automatically added. @item @code{skeletons} (default: @code{(default-skeletons)}) -A list target file name/file-like object tuples (@pxref{G-Expressions, +A list of target file name/file-like object tuples (@pxref{G-Expressions, file-like objects}). These are the skeleton files that will be added to the home directory of newly-created user accounts. -- cgit v1.2.3 From 4cafdce2102e3ebc7b3a6152464a62a454b6be45 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 9 Aug 2020 17:53:58 +0200 Subject: doc: Explain how to select system package outputs. * doc/guix.texi (operating-system Reference): Document that PACKAGES may contain traces of tuples and give an example. --- doc/guix.texi | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 4b13d4a00e..7855983bf2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11962,8 +11962,15 @@ A string denoting the contents of the @file{/etc/issue} file, which is displayed when users log in on a text console. @item @code{packages} (default: @code{%base-packages}) -The set of packages installed in the global profile, which is accessible -at @file{/run/current-system/profile}. +A list of packages to be installed in the global profile, which is accessible +at @file{/run/current-system/profile}. Each element is either a package +variable or a package/output tuple. Here's a simple example of both: + +@lisp +(cons* git ; only the default "out" output + (git "send-email") ; another output of the git package + %base-packages) ; the default set +@end lisp The default set includes core utilities and it is good practice to install non-core utilities in user profiles (@pxref{Invoking guix -- cgit v1.2.3 From 05e9709898c832213cbc430e1ec96728ae595383 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 9 Aug 2020 19:50:15 +0200 Subject: doc: Shrink width of deeply-indented code sample. This follows up on commit 4cafdce2102e3ebc7b3a6152464a62a454b6be45. * doc/guix.texi (operating-system Reference): Shorten comments to fit everything on an 80-character punch card. --- doc/guix.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 7855983bf2..337ffe6813 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11967,9 +11967,9 @@ at @file{/run/current-system/profile}. Each element is either a package variable or a package/output tuple. Here's a simple example of both: @lisp -(cons* git ; only the default "out" output - (git "send-email") ; another output of the git package - %base-packages) ; the default set +(cons* git ; the default "out" output + (git "send-email") ; another output of git + %base-packages) ; the default set @end lisp The default set includes core utilities and it is good practice to -- cgit v1.2.3 From 6376cb34b14e3daeb11ed9c12521c127b48753a2 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 9 Aug 2020 22:49:34 +0200 Subject: doc: Fix a typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi (operating-system Reference): Fix a typo & sigh. Reported by Jakub Kądziołka . --- doc/guix.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 337ffe6813..587c004bee 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11967,9 +11967,9 @@ at @file{/run/current-system/profile}. Each element is either a package variable or a package/output tuple. Here's a simple example of both: @lisp -(cons* git ; the default "out" output - (git "send-email") ; another output of git - %base-packages) ; the default set +(cons* git ; the default "out" output + (list git "send-email") ; another output of git + %base-packages) ; the default set @end lisp The default set includes core utilities and it is good practice to -- 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 'doc/guix.texi') 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 @@ (define-configuration docker-configuration "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 @@ (define (containerd-shepherd-service config) (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 @@ (define (docker-shepherd-service config) '()) (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 2a20c22dcf7b6a01eca5d1142d2a34c39f2f948a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 17 Aug 2020 15:38:03 -0400 Subject: doc: Fix a typo in the AutoSSH service documentation. * doc/guix.texi (Networking Services)[autossh-configuration]: Fix typo. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index e0c138533f..f562d0465e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15162,7 +15162,7 @@ a positive integer, ports @var{n} and @var{n}+1 are used for monitoring the connection, such that port @var{n} is the base monitoring port and @code{n+1} is the echo port. When set to @code{"@var{n}:@var{m}"} where @var{n} and @var{m} are positive -integers, the ports @var{n} and @var{n}+1 are used for monitoring the +integers, the ports @var{n} and @var{m} are used for monitoring the connection, such that port @var{n} is the base monitoring port and @var{m} is the echo port. -- cgit v1.2.3 From 4c0c65acfade63ce0549115d19db4b639c1e9992 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 27 Jul 2020 16:36:39 +0200 Subject: Use "guile-zlib" and "guile-lzlib" instead of (guix config). * Makefile.am (MODULES): Remove guix/zlib.scm and guix/lzlib.scm, (SCM_TESTS): remove tests/zlib.scm, tests/lzlib.scm. * build-aux/build-self.scm (make-config.scm): Remove unused %libz variable. * configure.ac: Remove LIBZ and LIBLZ variables and check instead for Guile-zlib and Guile-lzlib. * doc/guix.texi ("Requirements"): Remove zlib requirement and add Guile-zlib and Guile-lzlib instead. * gnu/packages/package-management.scm (guix)[native-inputs]: Add "guile-zlib" and "guile-lzlib", [inputs]: remove "zlib" and "lzlib", [propagated-inputs]: ditto, [arguments]: add "guile-zlib" and "guile-lzlib" to Guile load path. * guix/config.scm.in (%libz, %liblz): Remove them. * guix/lzlib.scm: Remove it. * guix/man-db.scm: Use (zlib) instead of (guix zlib). * guix/profiles.scm (manual-database): Do not stub (guix config) in imported modules list, instead add "guile-zlib" to the extension list. * guix/scripts/publish.scm: Use (zlib) instead of (guix zlib) and (lzlib) instead of (guix lzlib), (string->compression-type, effective-compression): do not check for zlib and lzlib availability. * guix/scripts/substitute.scm (%compression-methods): Do not check for lzlib availability. * guix/self.scm (specification->package): Add "guile-zlib" and "guile-lzlib" and remove "zlib" and "lzlib", (compiled-guix): remove "zlib" and "lzlib" arguments and add guile-zlib and guile-lzlib to the dependencies, also do not pass "zlib" and "lzlib" to "make-config.scm" procedure, (make-config.scm): remove "zlib" and "lzlib" arguments as well as %libz and %liblz variables. * guix/utils.scm (lzip-port): Use (lzlib) instead of (guix lzlib) and do not check for lzlib availability. * guix/zlib.scm: Remove it. * m4/guix.m4 (GUIX_LIBZ_LIBDIR, GUIX_LIBLZ_FILE_NAME): Remove them. * tests/lzlib.scm: Use (zlib) instead of (guix zlib) and (lzlib) instead of (guix lzlib), and do not check for zlib and lzlib availability. * tests/publish.scm: Ditto. * tests/substitute.scm: Do not check for lzlib availability. * tests/utils.scm: Ditto. * tests/zlib.scm: Remove it. --- Makefile.am | 6 +- build-aux/build-self.scm | 8 +- configure.ac | 33 +- doc/guix.texi | 3 +- gnu/packages/package-management.scm | 13 +- guix/config.scm.in | 8 - guix/gnu-maintenance.scm | 2 +- guix/lzlib.scm | 709 ------------------------------------ guix/man-db.scm | 2 +- guix/profiles.scm | 23 +- guix/scripts/publish.scm | 15 +- guix/scripts/substitute.scm | 3 +- guix/self.scm | 32 +- guix/utils.scm | 9 +- guix/zlib.scm | 241 ------------ m4/guix.m4 | 26 -- tests/lzlib.scm | 120 ------ tests/publish.scm | 28 +- tests/substitute.scm | 4 +- tests/utils.scm | 3 +- tests/zlib.scm | 62 ---- 21 files changed, 60 insertions(+), 1290 deletions(-) delete mode 100644 guix/lzlib.scm delete mode 100644 guix/zlib.scm delete mode 100644 tests/lzlib.scm delete mode 100644 tests/zlib.scm (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index a22414716b..4e50a33f82 100644 --- a/Makefile.am +++ b/Makefile.am @@ -109,8 +109,6 @@ MODULES = \ guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ - guix/zlib.scm \ - guix/lzlib.scm \ guix/build-system.scm \ guix/build-system/android-ndk.scm \ guix/build-system/ant.scm \ @@ -431,7 +429,6 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ - tests/lzlib.scm \ tests/modules.scm \ tests/monads.scm \ tests/nar.scm \ @@ -470,8 +467,7 @@ SCM_TESTS = \ tests/upstream.scm \ tests/utils.scm \ tests/uuid.scm \ - tests/workers.scm \ - tests/zlib.scm + tests/workers.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index e2495919d5..4b6e2bfae5 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -71,7 +71,7 @@ (define %config-variables (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir %system))) -(define* (make-config.scm #:key zlib gzip xz bzip2 +(define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -133,11 +133,7 @@ (define %gzip (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))))))) + #+(and xz (file-append xz "/bin/xz"))))))) ;;; diff --git a/configure.ac b/configure.ac index 7675eef7c4..5d549cc3af 100644 --- a/configure.ac +++ b/configure.ac @@ -141,6 +141,18 @@ if test "x$guix_cv_have_recent_guile_gcrypt" != "xyes"; then AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.]) fi +dnl Check for Guile-zlib. +GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)]) +if test "x$have_guile_zlib" != "xyes"; then + AC_MSG_ERROR([Guile-zlib is missing; please install it.]) +fi + +dnl Check for Guile-lzlib. +GUILE_MODULE_AVAILABLE([have_guile_lzlib], [(lzlib)]) +if test "x$have_guile_lzlib" != "xyes"; then + AC_MSG_ERROR([Guile-lzlib is missing; please install it.]) +fi + dnl Guile-newt is used by the graphical installer. GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)]) @@ -245,27 +257,6 @@ esac AC_SUBST([LIBGCRYPT_PREFIX]) AC_SUBST([LIBGCRYPT_LIBDIR]) -dnl Library name of zlib suitable for 'dynamic-link'. -GUIX_LIBZ_LIBDIR([libz_libdir]) -if test "x$libz_libdir" = "x"; then - LIBZ="libz" -else - LIBZ="$libz_libdir/libz" -fi -AC_MSG_CHECKING([for zlib's shared library name]) -AC_MSG_RESULT([$LIBZ]) -AC_SUBST([LIBZ]) - -dnl Library name of lzlib suitable for 'dynamic-link'. -GUIX_LIBLZ_FILE_NAME([LIBLZ]) -if test "x$LIBLZ" = "x"; then - LIBLZ="liblz" -else - # Strip the .so or .so.1 extension since that's what 'dynamic-link' expects. - LIBLZ="`echo $LIBLZ | sed -es'/\.so\(\.[[0-9.]]\+\)\?//g'`" -fi -AC_SUBST([LIBLZ]) - dnl Check for Guile-SSH, for the (guix ssh) module. GUIX_CHECK_GUILE_SSH AM_CONDITIONAL([HAVE_GUILE_SSH], diff --git a/doc/guix.texi b/doc/guix.texi index f562d0465e..4264ce5194 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -778,12 +778,13 @@ Guile,, gnutls-guile, GnuTLS-Guile}); @item @uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0 or later; +@item @uref{https://notabug.org/guile-zlib/guile-zlib, Guile-zlib}; +@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib}; @item @c FIXME: Specify a version number once a release has been made. @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August 2017 or later; @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x; -@item @url{https://zlib.net, zlib}; @item @url{https://www.gnu.org/software/make/, GNU Make}. @end itemize diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 4f419502b0..d7d279f795 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -279,6 +279,8 @@ (define code (gcrypt (assoc-ref inputs "guile-gcrypt")) (json (assoc-ref inputs "guile-json")) (sqlite (assoc-ref inputs "guile-sqlite3")) + (zlib (assoc-ref inputs "guile-zlib")) + (lzlib (assoc-ref inputs "guile-lzlib")) (git (assoc-ref inputs "guile-git")) (bs (assoc-ref inputs "guile-bytestructures")) @@ -286,7 +288,7 @@ (define code (gnutls (assoc-ref inputs "gnutls")) (locales (assoc-ref inputs "glibc-utf8-locales")) (deps (list gcrypt json sqlite gnutls - git bs ssh)) + git bs ssh zlib lzlib)) (effective (read-line (open-pipe* OPEN_READ @@ -326,6 +328,8 @@ (define code ("guile-gcrypt" ,guile-gcrypt) ("guile-json" ,guile-json-4) ("guile-sqlite3" ,guile-sqlite3) + ("guile-zlib" ,guile-zlib) + ("guile-lzlib" ,guile-lzlib) ("guile-ssh" ,guile-ssh) ("guile-git" ,guile-git) @@ -342,9 +346,6 @@ (define code (inputs `(("bzip2" ,bzip2) ("gzip" ,gzip) - ("zlib" ,zlib) ;for 'guix publish' - ("lzlib" ,lzlib) ;for 'guix publish' and 'guix substitute' - ("sqlite" ,sqlite) ("libgcrypt" ,libgcrypt) @@ -378,7 +379,9 @@ (define code ("guile-json" ,guile-json-4) ("guile-sqlite3" ,guile-sqlite3) ("guile-ssh" ,guile-ssh) - ("guile-git" ,guile-git))) + ("guile-git" ,guile-git) + ("guile-zlib" ,guile-zlib) + ("guile-lzlib" ,guile-lzlib))) (home-page "https://www.gnu.org/software/guix/") (synopsis "Functional package manager for installed software packages and versions") diff --git a/guix/config.scm.in b/guix/config.scm.in index 0ada0f3c38..b2901735d8 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -33,8 +33,6 @@ (define-module (guix config) %config-directory %system - %libz - %liblz %gzip %bzip2 %xz)) @@ -88,12 +86,6 @@ (define %config-directory (define %system "@guix_system@") -(define %libz - "@LIBZ@") - -(define %liblz - "@LIBLZ@") - (define %gzip "@GZIP@") diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index cd7109002b..08b2bcf758 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -36,7 +36,7 @@ (define-module (guix gnu-maintenance) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (guix zlib) + #:use-module (zlib) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder diff --git a/guix/lzlib.scm b/guix/lzlib.scm deleted file mode 100644 index 2fc326ba34..0000000000 --- a/guix/lzlib.scm +++ /dev/null @@ -1,709 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt -;;; Copyright © 2019, 2020 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix lzlib) - #:use-module (rnrs bytevectors) - #:use-module (rnrs arithmetic bitwise) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module (guix config) - #:use-module (srfi srfi-11) - #:export (lzlib-available? - make-lzip-input-port - make-lzip-output-port - make-lzip-input-port/compressed - call-with-lzip-input-port - call-with-lzip-output-port - %default-member-length-limit - %default-compression-level - dictionary-size+match-length-limit)) - -;;; Commentary: -;;; -;;; Bindings to the lzlib / liblz API. Some convenience functions are also -;;; provided (see the export). -;;; -;;; While the bindings are complete, the convenience functions only support -;;; single member archives. To decompress single member archives, we loop -;;; until lz-decompress-read returns 0. This is simpler. To support multiple -;;; members properly, we need (among others) to call lz-decompress-finish and -;;; loop over lz-decompress-read until lz-decompress-finished? returns #t. -;;; Otherwise a multi-member archive starting with an empty member would only -;;; decompress the empty member and stop there, resulting in truncated output. - -;;; Code: - -(define %lzlib - ;; File name of lzlib's shared library. When updating via 'guix pull', - ;; '%liblz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%liblz) - %liblz - "liblz")))) - -(define (lzlib-available?) - "Return true if lzlib is available, #f otherwise." - (false-if-exception (force %lzlib))) - -(define (lzlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in liblz, or #f if -either lzlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %lzlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'LZ_Decoder' opaque type. - lz-decoder? - pointer->lz-decoder - lz-decoder->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'LZ_Encoder' opaque type. - lz-encoder? - pointer->lz-encoder - lz-encoder->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -;; From lzlib.h -(define %error-number-ok 0) -(define %error-number-bad-argument 1) -(define %error-number-mem-error 2) -(define %error-number-sequence-error 3) -(define %error-number-header-error 4) -(define %error-number-unexpected-eof 5) -(define %error-number-data-error 6) -(define %error-number-library-error 7) - - -;; Compression bindings. - -(define lz-compress-open - (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64))) - ;; member-size is an "unsigned long long", and the C standard guarantees - ;; a minimum range of 0..2^64-1. - (unlimited-size (- (expt 2 64) 1))) - (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size)) - "Initialize the internal stream state for compression and returns a -pointer that can only be used as the encoder argument for the other -lz-compress functions, or a null pointer if the encoder could not be -allocated. - -See the manual: (lzlib) Compression functions." - (let ((encoder-ptr (proc dictionary-size match-length-limit member-size))) - (if (not (= (lz-compress-error encoder-ptr) -1)) - (pointer->lz-encoder encoder-ptr) - (throw 'lzlib-error 'lz-compress-open)))))) - -(define lz-compress-close - (let ((proc (lzlib-procedure int "LZ_compress_close" '(*)))) - (lambda (encoder) - "Close encoder. ENCODER can no longer be used as an argument to any -lz-compress function. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-close ret) - ret))))) - -(define lz-compress-finish - (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*)))) - (lambda (encoder) - "Tell that all the data for this member have already been written (with -the `lz-compress-write' function). It is safe to call `lz-compress-finish' as -many times as needed. After all the produced compressed data have been read -with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new -member can be started with 'lz-compress-restart-member'." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder)) - ret))))) - -(define lz-compress-restart-member - (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64)))) - (lambda (encoder member-size) - "Start a new member in a multimember data stream. -Call this function only after `lz-compress-member-finished?' indicates that the -current member has been fully read (with the `lz-compress-read' function)." - (let ((ret (proc (lz-encoder->pointer encoder) member-size))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-restart-member - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-sync-flush - (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*)))) - (lambda (encoder) - "Make available to `lz-compress-read' all the data already written with -the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then -call 'lz-compress-read' until it returns 0. - -Repeated use of `LZ-compress-sync-flush' may degrade compression ratio, -so use it only when needed. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-sync-flush - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-read - (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int)))) - (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv))) - "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV. -Return the number of uncompressed bytes written, a positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer lzfile-bv start) - count))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write - (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int)))) - (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the encoder stream. Return the -number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write-size - (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*)))) - (lambda (encoder) - "The maximum number of bytes that can be immediately written through the -`lz-compress-write' function. - -It is guaranteed that an immediate call to `lz-compress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder)) - ret))))) - -(define lz-compress-error - (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*)))) - (lambda (encoder) - "ENCODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-encoder? encoder) - (lz-encoder->pointer encoder) - encoder)))) - error-number)))) - -(define lz-compress-finished? - (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*)))) - (lambda (encoder) - "Return #t if all the data have been read and `lz-compress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-member-finished? - (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*)))) - (lambda (encoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and 'lz-compress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*)))) - (lambda (encoder) - "Return the number of input bytes already compressed in the current -member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-data-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*)))) - (lambda (encoder) - "Return the number of compressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-member-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*)))) - (lambda (encoder) - "Return the total number of input bytes already compressed." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-in-size - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*)))) - (lambda (encoder) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-out-size - (lz-compress-error encoder)) - ret))))) - - -;; Decompression bindings. - -(define lz-decompress-open - (let ((proc (lzlib-procedure '* "LZ_decompress_open" '()))) - (lambda () - "Initializes the internal stream state for decompression and returns a -pointer that can only be used as the decoder argument for the other -lz-decompress functions, or a null pointer if the decoder could not be -allocated. - -See the manual: (lzlib) Decompression functions." - (let ((decoder-ptr (proc))) - (if (not (= (lz-decompress-error decoder-ptr) -1)) - (pointer->lz-decoder decoder-ptr) - (throw 'lzlib-error 'lz-decompress-open)))))) - -(define lz-decompress-close - (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*)))) - (lambda (decoder) - "Close decoder. DECODER can no longer be used as an argument to any -lz-decompress function. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-close ret) - ret))))) - -(define lz-decompress-finish - (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*)))) - (lambda (decoder) - "Tell that all the data for this stream have already been written (with -the `lz-decompress-write' function). It is safe to call -`lz-decompress-finish' as many times as needed." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-reset - (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*)))) - (lambda (decoder) - "Reset the internal state of DECODER as it was just after opening it -with the `lz-decompress-open' function. Data stored in the internal buffers -is discarded. Position counters are set to 0." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-reset - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-sync-to-member - (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*)))) - (lambda (decoder) - "Reset the error state of DECODER and enters a search state that lasts -until a new member header (or the end of the stream) is found. After a -successful call to `lz-decompress-sync-to-member', data written with -`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0 -until a header is found. - -This function is useful to discard any data preceding the first member, or to -discard the rest of the current member, for example in case of a data -error. If the decoder is already at the beginning of a member, this function -does nothing." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-sync-to-member - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-read - (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int)))) - (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv))) - "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV. -Return the number of uncompressed bytes written, a non-negative positive integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer file-bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write - (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int)))) - (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the decoder stream. Return the -number of uncompressed bytes written, a non-negative integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write-size - (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*)))) - (lambda (decoder) - "Return the maximum number of bytes that can be immediately written -through the `lz-decompress-write' function. - -It is guaranteed that an immediate call to `lz-decompress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-error - (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*)))) - (lambda (decoder) - "DECODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-decoder? decoder) - (lz-decoder->pointer decoder) - decoder)))) - error-number)))) - -(define lz-decompress-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*)))) - (lambda (decoder) - "Return #t if all the data have been read and `lz-decompress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*)))) - (lambda (decoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and `lz-decompress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-version - (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the version of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-dictionary-size - (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the dictionary size of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-crc - (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the 32 bit Cyclic Redundancy Check of the data decompressed -from the current member. The returned value is valid only when -`lz-decompress-member-finished' returns #t. " - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*)))) - (lambda (decoder) - "Return the number of decompressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*)))) - (lambda (decoder) - "Return the number of input bytes already decompressed in the current -member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of input bytes already compressed." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-in-size - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-out-size - (lz-decompress-error decoder)) - ret))))) - - -;; High level functions. - -(define* (lzread! decoder port bv - #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from PORT into BV at offset START. Return the -number of uncompressed bytes actually read; it is zero if COUNT is zero or if -the end-of-stream has been reached." - (define (feed-decoder! decoder) - ;; Feed DECODER with data read from PORT. - (match (get-bytevector-n port (lz-decompress-write-size decoder)) - ((? eof-object? eof) eof) - (bv (lz-decompress-write decoder bv)))) - - (let loop ((read 0) - (start start)) - (cond ((< read count) - (match (lz-decompress-read decoder bv start (- count read)) - (0 (cond ((lz-decompress-finished? decoder) - read) - ((eof-object? (feed-decoder! decoder)) - (lz-decompress-finish decoder) - (loop read start)) - (else ;read again - (loop read start)))) - (n (loop (+ read n) (+ start n))))) - (else - read)))) - -(define (lzwrite! encoder source source-offset source-count - target target-offset target-count) - "Write up to SOURCE-COUNT bytes from SOURCE to ENCODER, and read up to -TARGET-COUNT bytes into TARGET at TARGET-OFFSET. Return two values: the -number of bytes read from SOURCE, and the number of bytes written to TARGET, -possibly zero." - (define read - (if (> (lz-compress-write-size encoder) 0) - (match (lz-compress-write encoder source source-offset source-count) - (0 (lz-compress-finish encoder) 0) - (n n)) - 0)) - - (define written - (lz-compress-read encoder target target-offset target-count)) - - (values read written)) - -(define* (lzwrite encoder bv lz-port - #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return -the number of uncompressed bytes written, a non-negative integer." - (let ((written 0) - (read 0)) - (while (and (< 0 (lz-compress-write-size encoder)) - (< written count)) - (set! written (+ written - (lz-compress-write encoder bv (+ start written) (- count written))))) - (when (= written 0) - (lz-compress-finish encoder)) - (let ((lz-bv (make-bytevector written))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector lz-port lz-bv 0 rd) - (set! read (+ read rd)) - (unless (= rd 0) - (loop rd)))) - ;; `written' is the total byte count of uncompressed data. - written)) - - -;;; -;;; Port interface. -;;; - -;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest. -;; See bbexample.c in lzlib's source. -(define %compression-levels - `((0 65535 16) - (1 ,(bitwise-arithmetic-shift-left 1 20) 5) - (2 ,(bitwise-arithmetic-shift-left 3 19) 6) - (3 ,(bitwise-arithmetic-shift-left 1 21) 8) - (4 ,(bitwise-arithmetic-shift-left 3 20) 12) - (5 ,(bitwise-arithmetic-shift-left 1 22) 20) - (6 ,(bitwise-arithmetic-shift-left 1 23) 36) - (7 ,(bitwise-arithmetic-shift-left 1 24) 68) - (8 ,(bitwise-arithmetic-shift-left 3 23) 132) - (9 ,(bitwise-arithmetic-shift-left 1 25) 273))) - -(define %default-compression-level - 6) - -(define (dictionary-size+match-length-limit level) - "Return two values: the dictionary size for LEVEL, and its match-length -limit. LEVEL must be a compression level, an integer between 0 and 9." - (match (assv-ref %compression-levels level) - ((dictionary-size match-length-limit) - (values dictionary-size match-length-limit)))) - -(define* (make-lzip-input-port port) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed." - (define decoder (lz-decompress-open)) - - (define (read! bv start count) - (lzread! decoder port bv start count)) - - (make-custom-binary-input-port "lzip-input" read! #f #f - (lambda () - (lz-decompress-close decoder) - (close-port port)))) - -(define* (make-lzip-output-port port - #:key - (level %default-compression-level)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define encoder - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (define (write! bv start count) - (lzwrite encoder bv port start count)) - - (make-custom-binary-output-port "lzip-output" write! #f #f - (lambda () - (lz-compress-finish encoder) - ;; "lz-read" the trailing metadata added by `lz-compress-finish'. - (let ((lz-bv (make-bytevector (* 64 1024)))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector port lz-bv 0 rd) - (unless (= rd 0) - (loop rd)))) - (lz-compress-close encoder) - (close-port port)))) - -(define* (make-lzip-input-port/compressed port - #:key - (level %default-compression-level)) - "Return an input port that compresses data read from PORT, with the given LEVEL. -PORT is automatically closed when the resulting port is closed." - (define encoder - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (define input-buffer (make-bytevector 8192)) - (define input-len 0) - (define input-offset 0) - - (define input-eof? #f) - - (define (read! bv start count) - (cond - (input-eof? - (match (lz-compress-read encoder bv start count) - (0 (if (lz-compress-finished? encoder) - 0 - (read! bv start count))) - (n n))) - ((= input-offset input-len) - (match (get-bytevector-n! port input-buffer 0 - (bytevector-length input-buffer)) - ((? eof-object?) - (set! input-eof? #t) - (lz-compress-finish encoder)) - (count - (set! input-offset 0) - (set! input-len count))) - (read! bv start count)) - (else - (let-values (((read written) - (lzwrite! encoder - input-buffer input-offset - (- input-len input-offset) - bv start count))) - (set! input-offset (+ input-offset read)) - - ;; Make sure we don't return zero except on EOF. - (if (= 0 written) - (read! bv start count) - written))))) - - (make-custom-binary-input-port "lzip-input/compressed" - read! #f #f - (lambda () - (close-port port)))) - -(define* (call-with-lzip-input-port port proc) - "Call PROC with a port that wraps PORT and decompresses data read from it. -PORT is closed upon completion." - (let ((lzip (make-lzip-input-port port))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -(define* (call-with-lzip-output-port port proc - #:key - (level %default-compression-level)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion." - (let ((lzip (make-lzip-output-port port - #:level level))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -;;; lzlib.scm ends here diff --git a/guix/man-db.scm b/guix/man-db.scm index 4cef874f8b..a6528e4431 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix man-db) - #:use-module (guix zlib) + #:use-module (zlib) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) diff --git a/guix/profiles.scm b/guix/profiles.scm index 0619e735fb..6b2344270e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1412,27 +1412,18 @@ (define gdbm-ffi (module-ref (resolve-interface '(gnu packages guile)) 'guile-gdbm-ffi)) - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module #$'(guix config) ;placate Geiser - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure `((guix build utils) - (guix man-db)))))) + (delete '(guix config) + (source-module-closure `((guix build utils) + (guix man-db))))) (define build (with-imported-modules modules - (with-extensions (list gdbm-ffi) ;for (guix man-db) + (with-extensions (list gdbm-ffi ;for (guix man-db) + guile-zlib) #~(begin (use-modules (guix man-db) (guix build utils) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a00f08f9d9..61542f83a0 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -50,10 +50,9 @@ (define-module (guix scripts publish) #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) - #:use-module (guix zlib) - #:autoload (guix lzlib) (lzlib-available? - call-with-lzip-output-port - make-lzip-output-port) + #:use-module (zlib) + #:autoload (lzlib) (call-with-lzip-output-port + make-lzip-output-port) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -880,8 +879,8 @@ (define (string->compression-type string) "Return a symbol denoting the compression method expressed by STRING; return #f if STRING doesn't match any supported method." (match string - ("gzip" (and (zlib-available?) 'gzip)) - ("lzip" (and (lzlib-available?) 'lzip)) + ("gzip" 'gzip) + ("lzip" 'lzip) (_ #f))) (define (effective-compression requested-type compressions) @@ -1032,9 +1031,7 @@ (define (guix-publish . args) opts) (() ;; Default to fast & low compression. - (list (if (zlib-available?) - %default-gzip-compression - %no-compression))) + (list %default-gzip-compression)) (lst (reverse lst)))) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ba2b2d2d4e..f9d19fd735 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -41,7 +41,6 @@ (define-module (guix scripts substitute) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) - #:autoload (guix lzlib) (lzlib-available?) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -912,7 +911,7 @@ (define %compression-methods ;; Known compression methods and a thunk to determine whether they're ;; supported. See 'decompressed-port' in (guix utils). `(("gzip" . ,(const #t)) - ("lzip" . ,lzlib-available?) + ("lzip" . ,(const #t)) ("xz" . ,(const #t)) ("bzip2" . ,(const #t)) ("none" . ,(const #t)))) diff --git a/guix/self.scm b/guix/self.scm index f70b1ecdd8..6a1640acdf 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -53,10 +53,10 @@ (define specification->package ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) + ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) + ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls)) - ("zlib" (ref '(gnu packages compression) 'zlib)) - ("lzlib" (ref '(gnu packages compression) 'lzlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) @@ -727,8 +727,6 @@ (define* (compiled-guix source #:key (version %guix-version) (name (string-append "guix-" version)) (guile-version (effective-version)) (guile-for-build (default-guile)) - (zlib (specification->package "zlib")) - (lzlib (specification->package "lzlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) (xz (specification->package "xz")) @@ -746,6 +744,12 @@ (define guile-git (define guile-sqlite3 (specification->package "guile-sqlite3")) + (define guile-zlib + (specification->package "guile-zlib")) + + (define guile-lzlib + (specification->package "guile-lzlib")) + (define guile-gcrypt (specification->package "guile-gcrypt")) @@ -757,7 +761,7 @@ (define dependencies (cons (list "x" package) (package-transitive-propagated-inputs package))) (list guile-gcrypt gnutls guile-git guile-json - guile-ssh guile-sqlite3)) + guile-ssh guile-sqlite3 guile-zlib guile-lzlib)) (((labels packages _ ...) ...) packages))) @@ -884,9 +888,7 @@ (define *config* '() #:extra-modules `(((guix config) - => ,(make-config.scm #:zlib zlib - #:lzlib lzlib - #:gzip gzip + => ,(make-config.scm #:gzip gzip #:bzip2 bzip2 #:xz xz #:package-name @@ -983,7 +985,7 @@ (define %config-variables (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir))) -(define* (make-config.scm #:key zlib lzlib gzip xz bzip2 +(define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -1004,8 +1006,6 @@ (define defmod 'define-module) %state-directory %store-database-directory %config-directory - %libz - %liblz %gzip %bzip2 %xz)) @@ -1048,15 +1048,7 @@ (define %gzip (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))) - - (define %liblz - #+(and lzlib - (file-append lzlib "/lib/liblz")))) + #+(and xz (file-append xz "/bin/xz")))) ;; Guile 2.0 *requires* the 'define-module' to be at the ;; top-level or the 'toplevel-ref' in the resulting .go file are diff --git a/guix/utils.scm b/guix/utils.scm index fc57c416a0..b816c355dc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -208,13 +208,8 @@ (define (filtered-port command input) (define (lzip-port proc port . args) "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. Raise an error if lzlib support is missing." - (let* ((lzlib (false-if-exception (resolve-interface '(guix lzlib)))) - (supported? (and lzlib - ((module-ref lzlib 'lzlib-available?))))) - (if supported? - (let ((make-port (module-ref lzlib proc))) - (values (make-port port) '())) - (error "lzip compression not supported" lzlib)))) + (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) + (values (make-port port) '()))) (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, diff --git a/guix/zlib.scm b/guix/zlib.scm deleted file mode 100644 index 3bd0ad86c9..0000000000 --- a/guix/zlib.scm +++ /dev/null @@ -1,241 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix zlib) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module (guix config) - #:export (zlib-available? - make-gzip-input-port - make-gzip-output-port - call-with-gzip-input-port - call-with-gzip-output-port - %default-buffer-size - %default-compression-level)) - -;;; Commentary: -;;; -;;; Bindings to the gzip-related part of zlib's API. The main limitation of -;;; this API is that it requires a file descriptor as the source or sink. -;;; -;;; Code: - -(define %zlib - ;; File name of zlib's shared library. When updating via 'guix pull', - ;; '%libz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%libz) - %libz - "libz")))) - -(define (zlib-available?) - "Return true if zlib is available, #f otherwise." - (false-if-exception (force %zlib))) - -(define (zlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in libz, or #f if -either zlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %zlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'gzFile' opaque type. - gzip-file? - pointer->gzip-file - gzip-file->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -(define gzerror - (let ((proc (zlib-procedure '* "gzerror" '(* *)))) - (lambda (gzfile) - (let* ((errnum* (make-bytevector (sizeof int))) - (ptr (proc (gzip-file->pointer gzfile) - (bytevector->pointer errnum*)))) - (values (bytevector-sint-ref errnum* 0 - (native-endianness) (sizeof int)) - (pointer->string ptr)))))) - -(define gzdopen - (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) - (lambda (fd mode) - "Open file descriptor FD as a gzip stream with the given MODE. MODE must -be a string denoting the how FD is to be opened, such as \"r\" for reading or -\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also -closes FD." - (let ((result (proc fd (string->pointer mode)))) - (if (null-pointer? result) - (throw 'zlib-error 'gzdopen) - (pointer->gzip-file result)))))) - -(define gzread! - (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from GZFILE into BV at offset START. Return the -number of uncompressed bytes actually read; it is zero if COUNT is zero or if -the end-of-stream has been reached." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'zlib-error 'gzread! ret) - ret))))) - -(define gzwrite - (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV at offset START into GZFILE. Return -the number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (<= ret 0) - (throw 'zlib-error 'gzwrite ret) - ret))))) - -(define gzbuffer! - (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) - (lambda (gzfile size) - "Change the internal buffer size of GZFILE to SIZE bytes." - (let ((ret (proc (gzip-file->pointer gzfile) size))) - (unless (zero? ret) - (throw 'zlib-error 'gzbuffer! ret)))))) - -(define gzeof? - (let ((proc (zlib-procedure int "gzeof" '(*)))) - (lambda (gzfile) - "Return true if the end-of-file has been reached on GZFILE." - (not (zero? (proc (gzip-file->pointer gzfile))))))) - -(define gzclose - (let ((proc (zlib-procedure int "gzclose" '(*)))) - (lambda (gzfile) - "Close GZFILE." - (let ((ret (proc (gzip-file->pointer gzfile)))) - (unless (zero? ret) - (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) - - - -;;; -;;; Port interface. -;;; - -(define %default-buffer-size - ;; Default buffer size, as documented in . - 8192) - -(define %default-compression-level - ;; Z_DEFAULT_COMPRESSION. - -1) - -(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed. BUFFER-SIZE -is the size in bytes of the internal buffer, 8 KiB by default; using a larger -buffer increases decompression speed. An error is thrown if PORT contains -buffered input, which would be lost (and is lost anyway)." - (define gzfile - (match (drain-input port) - ("" ;PORT's buffer is empty - ;; 'gzclose' will eventually close the file descriptor beneath PORT. - ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, - ;; so that's no good; revealed ports are no good either because they - ;; leak (see ); calling 'close-port' after - ;; 'gzclose' doesn't work either because it leads to a race condition - ;; (see ). So we dup and close PORT right - ;; away. - (gzdopen (dup (fileno port)) "r")) - (_ - ;; This is unrecoverable but it's better than having the buffered input - ;; be lost, leading to unclear end-of-file or corrupt-data errors down - ;; the path. - (throw 'zlib-error 'make-gzip-input-port - "port contains buffered input" port)))) - - (define (read! bv start count) - (gzread! gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) ;we no longer need it - (make-custom-binary-input-port "gzip-input" read! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (make-gzip-output-port port - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define gzfile - (begin - (force-output port) ;empty PORT's buffer - (gzdopen (dup (fileno port)) - (string-append "w" (number->string level))))) - - (define (write! bv start count) - (gzwrite gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) - (make-custom-binary-output-port "gzip-output" write! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (call-with-gzip-input-port port proc - #:key (buffer-size %default-buffer-size)) - "Call PROC with a port that wraps PORT and decompresses data read from it. -PORT is closed upon completion. The gzip internal buffer size is set to -BUFFER-SIZE bytes." - (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -(define* (call-with-gzip-output-port port proc - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion. The gzip internal buffer size is set to BUFFER-SIZE -bytes." - (let ((gzip (make-gzip-output-port port - #:level level - #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -;;; zlib.scm ends here diff --git a/m4/guix.m4 b/m4/guix.m4 index cce03045db..b7bf74ccc8 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -342,32 +342,6 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ $1="$guix_cv_libgcrypt_libdir" ]) -dnl GUIX_LIBZ_LIBDIR VAR -dnl -dnl Attempt to determine libz's LIBDIR; store the result in VAR. -AC_DEFUN([GUIX_LIBZ_LIBDIR], [ - AC_REQUIRE([PKG_PROG_PKG_CONFIG]) - AC_CACHE_CHECK([zlib's library directory], - [guix_cv_libz_libdir], - [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"]) - $1="$guix_cv_libz_libdir" -]) - -dnl GUIX_LIBLZ_FILE_NAME VAR -dnl -dnl Attempt to determine liblz's absolute file name; store the result in VAR. -AC_DEFUN([GUIX_LIBLZ_FILE_NAME], [ - AC_REQUIRE([PKG_PROG_PKG_CONFIG]) - AC_CACHE_CHECK([lzlib's file name], - [guix_cv_liblz_libdir], - [old_LIBS="$LIBS" - LIBS="-llz" - AC_LINK_IFELSE([AC_LANG_SOURCE([int main () { return LZ_decompress_open(); }])], - [guix_cv_liblz_libdir="`ldd conftest$EXEEXT | grep liblz | sed '-es/.*=> \(.*\) .*$/\1/g'`"]) - LIBS="$old_LIBS"]) - $1="$guix_cv_liblz_libdir" -]) - dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/lzlib.scm b/tests/lzlib.scm deleted file mode 100644 index 63d1e15641..0000000000 --- a/tests/lzlib.scm +++ /dev/null @@ -1,120 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (test-lzlib) - #:use-module (guix lzlib) - #:use-module (guix tests) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (ice-9 match)) - -;; Test the (guix lzlib) module. - -(define-syntax-rule (test-assert* description exp) - (begin - (unless (lzlib-available?) - (test-skip 1)) - (test-assert description exp))) - -(test-begin "lzlib") - -(define (compress-and-decompress data) - "DATA must be a bytevector." - (pk "Uncompressed bytes:" (bytevector-length data)) - (match (pipe) - ((parent . child) - (match (primitive-fork) - (0 ;compress - (dynamic-wind - (const #t) - (lambda () - (close-port parent) - (call-with-lzip-output-port child - (lambda (port) - (put-bytevector port data)))) - (lambda () - (primitive-exit 0)))) - (pid ;decompress - (begin - (close-port child) - (let ((received (call-with-lzip-input-port parent - (lambda (port) - (get-bytevector-all port))))) - (match (waitpid pid) - ((_ . status) - (pk "Status" status) - (pk "Length data" (bytevector-length data) "received" (bytevector-length received)) - ;; The following loop is a debug helper. - (let loop ((i 0)) - (if (and (< i (bytevector-length received)) - (= (bytevector-u8-ref received i) - (bytevector-u8-ref data i))) - (loop (+ 1 i)) - (pk "First diff at index" i))) - (and (zero? status) - (port-closed? parent) - (bytevector=? received data))))))))))) - -(test-assert* "null bytevector" - (compress-and-decompress (make-bytevector (+ (random 100000) - (* 20 1024))))) - -(test-assert* "random bytevector" - (compress-and-decompress (random-bytevector (+ (random 100000) - (* 20 1024))))) -(test-assert* "small bytevector" - (compress-and-decompress (random-bytevector 127))) - -(test-assert* "1 bytevector" - (compress-and-decompress (random-bytevector 1))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (2 * dictionary)" - (compress-and-decompress - (random-bytevector - (* 2 (dictionary-size+match-length-limit %default-compression-level))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB)" - (compress-and-decompress (random-bytevector (* 64 1024)))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB-1)" - (compress-and-decompress (random-bytevector (1- (* 64 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB+1)" - (compress-and-decompress (random-bytevector (1+ (* 64 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB)" - (compress-and-decompress (random-bytevector (* 1024 1024)))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB-1)" - (compress-and-decompress (random-bytevector (1- (* 1024 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)" - (compress-and-decompress (random-bytevector (1+ (* 1024 1024))))) - -(test-assert* "make-lzip-input-port/compressed" - (let* ((len (pk 'len (+ 10 (random 4000 %seed)))) - (data (random-bytevector len)) - (compressed (make-lzip-input-port/compressed - (open-bytevector-input-port data))) - (result (call-with-lzip-input-port compressed - get-bytevector-all))) - (pk (bytevector-length result) (bytevector-length data)) - (bytevector=? result data))) - -(test-end) diff --git a/tests/publish.scm b/tests/publish.scm index e43310ef00..1c3b2785fb 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -35,8 +35,8 @@ (define-module (test-publish) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (gcrypt pk-crypto) #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) - #:use-module (guix zlib) - #:use-module (guix lzlib) + #:use-module (zlib) + #:use-module (lzlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -204,8 +204,6 @@ (define %gzip-magic-bytes (call-with-input-string nar (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/nar/gzip/*" "bar" (call-with-temporary-output-file @@ -217,8 +215,6 @@ (define %gzip-magic-bytes (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/nar/gzip/* is really gzip" %gzip-magic-bytes ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads @@ -229,8 +225,6 @@ (define %gzip-magic-bytes (string-append "/nar/gzip/" (basename %item)))))) (get-bytevector-n nar (bytevector-length %gzip-magic-bytes)))) -(unless (lzlib-available?) - (test-skip 1)) (test-equal "/nar/lzip/*" "bar" (call-with-temporary-output-file @@ -242,8 +236,6 @@ (define %gzip-magic-bytes (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/*.narinfo with compression" `(("StorePath" . ,%item) ("URL" . ,(string-append "nar/gzip/" (basename %item))) @@ -264,8 +256,6 @@ (define %gzip-magic-bytes (_ #f))) (recutils->alist body))))) -(unless (lzlib-available?) - (test-skip 1)) (test-equal "/*.narinfo with lzip compression" `(("StorePath" . ,%item) ("URL" . ,(string-append "nar/lzip/" (basename %item))) @@ -286,8 +276,6 @@ (define %gzip-magic-bytes (_ #f))) (recutils->alist body))))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/*.narinfo for a compressed file" '("none" "nar") ;compression-less nar ;; Assume 'guix publish -C' is already running on port 6799. @@ -300,8 +288,6 @@ (define %gzip-magic-bytes (list (assoc-ref info "Compression") (dirname (assoc-ref info "URL"))))) -(unless (and (zlib-available?) (lzlib-available?)) - (test-skip 1)) (test-equal "/*.narinfo with lzip + gzip" `((("StorePath" . ,%item) ("URL" . ,(string-append "nar/gzip/" (basename %item))) @@ -411,8 +397,6 @@ (define %gzip-magic-bytes (call-with-input-string "" port-sha256)))))) (response-code (http-get uri)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "with cache" (list #t `(("StorePath" . ,%item) @@ -469,8 +453,6 @@ (define %gzip-magic-bytes (stat:size (stat nar))) (response-code uncompressed))))))))) -(unless (and (zlib-available?) (lzlib-available?)) - (test-skip 1)) (test-equal "with cache, lzip + gzip" '(200 200 404) (call-with-temporary-directory @@ -515,8 +497,6 @@ (define %gzip-magic-bytes (response-code (http-get uncompressed)))))))))) -(unless (zlib-available?) - (test-skip 1)) (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" (random-text)))) (test-equal "with cache, uncompressed" @@ -596,9 +576,7 @@ (define %gzip-magic-bytes (item (add-text-to-store %store "random" (random-text))) (part (store-path-hash-part item)) (url (string-append base part ".narinfo")) - (cached (string-append cache - (if (zlib-available?) - "/gzip/" "/none/") + (cached (string-append cache "/gzip/" (basename item) ".narinfo")) (response (http-get url))) diff --git a/tests/substitute.scm b/tests/substitute.scm index a4246aff82..6560612c40 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -29,7 +29,6 @@ (define-module (test-substitute) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) #:use-module ((guix utils) #:select (call-with-compressed-output-port)) - #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) @@ -508,8 +507,7 @@ (define (compress input output compression) (let ((nar (string-append %main-substitute-directory "/example.nar"))) (compress nar (string-append nar ".gz") 'gzip) - (when (lzlib-available?) - (compress nar (string-append nar ".lz") 'lzip))) + (compress nar (string-append nar ".lz") 'lzip)) (parameterize ((substitute-urls (list (string-append "file://" diff --git a/tests/utils.scm b/tests/utils.scm index f78ec356bd..009e2121ab 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -23,7 +23,6 @@ (define-module (test-utils) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix search-paths) #:select (string-tokenize*)) - #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -215,7 +214,7 @@ (define (test-compression/decompression method run?) (for-each test-compression/decompression '(gzip xz lzip) - (list (const #t) (const #t) lzlib-available?)) + (list (const #t) (const #t) (const #t))) ;; This is actually in (guix store). (test-equal "store-path-package-name" diff --git a/tests/zlib.scm b/tests/zlib.scm deleted file mode 100644 index 7c595a422c..0000000000 --- a/tests/zlib.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2019 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (test-zlib) - #:use-module (guix zlib) - #:use-module (guix tests) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (ice-9 match)) - -;; Test the (guix zlib) module. - -(test-begin "zlib") - -(unless (zlib-available?) - (test-skip 1)) -(test-assert "compression/decompression pipe" - (let ((data (random-bytevector (+ (random 10000) - (* 20 1024))))) - (match (pipe) - ((parent . child) - (match (primitive-fork) - (0 ;compress - (dynamic-wind - (const #t) - (lambda () - (close-port parent) - (call-with-gzip-output-port child - (lambda (port) - (put-bytevector port data)))) - (lambda () - (primitive-exit 0)))) - (pid ;decompress - (begin - (close-port child) - (let ((received (call-with-gzip-input-port parent - (lambda (port) - (get-bytevector-all port)) - #:buffer-size (* 64 1024)))) - (match (waitpid pid) - ((_ . status) - (and (zero? status) - (port-closed? parent) - (bytevector=? received data)))))))))))) - -(test-end) -- 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 'doc/guix.texi') 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 @@ (define-module (gnu services admin) 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 @@ (define rottlog-service-type (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 @@ (define services (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 @@ (define-syntax-rule (with-logging exp ...) (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 bff22b76f38ab790248add90fc8bc11e9f9c4955 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 25 Aug 2020 16:07:30 +0200 Subject: doc: Fix typo. * doc/guix.texi (Virtualization Services): Fix typo. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index fed904411a..91d3860978 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25628,7 +25628,7 @@ When true, the daemon performs additional logging for debugging purposes. @defvr {Scheme Variable} ganeti-luxid-service-type @command{ganeti-luxid} is a daemon used to answer queries related to the configuration and the current live state of a Ganeti cluster. Additionally, -it is the authorative daemon for the Ganeti job queue. Jobs can be +it is the authoritative daemon for the Ganeti job queue. Jobs can be submitted via this daemon and it schedules and starts them. It takes a @code{ganeti-luxid-configuration} object. -- cgit v1.2.3 From 4b5a6fbc9b754c0ca70d033dd99f17c4f028733a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 24 Aug 2020 16:26:14 -0400 Subject: offload: Modify the build-machine record to accept multiple systems. * guix/scripts/offload.scm ()[systems]: New field. [system]: Accessor changed to %build-machine-system. Default to #f. * guix/scripts/offload.scm (build-machine-system): Wrap %build-machine-system with a deprecation warning. (build-machine-systems): Access the new systems field or fallback to use build-machine-system, for backward compatibility. (machine-matches?): Adjust. * tests/offload.scm: Add tests... * Makefile.am (SCM_TESTS): ...and register them. * doc/guix.texi (Daemon Offload Setup): Update doc. --- Makefile.am | 1 + doc/guix.texi | 35 +++++++++++++----------- guix/scripts/offload.scm | 24 +++++++++++++--- tests/offload.scm | 71 ++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 111 insertions(+), 20 deletions(-) create mode 100644 tests/offload.scm (limited to 'doc/guix.texi') diff --git a/Makefile.am b/Makefile.am index 4e50a33f82..9c38c2f83c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -433,6 +433,7 @@ SCM_TESTS = \ tests/monads.scm \ tests/nar.scm \ tests/networking.scm \ + tests/offload.scm \ tests/opam.scm \ tests/openpgp.scm \ tests/packages.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 91d3860978..0b79a49814 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1043,29 +1043,31 @@ When desired, the build daemon can @dfn{offload} derivation builds to other machines running Guix, using the @code{offload} @dfn{build hook}@footnote{This feature is available only when @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is -present.}. When that -feature is enabled, a list of user-specified build machines is read from -@file{/etc/guix/machines.scm}; every time a build is requested, for -instance via @code{guix build}, the daemon attempts to offload it to one -of the machines that satisfy the constraints of the derivation, in -particular its system type---e.g., @file{x86_64-linux}. Missing -prerequisites for the build are copied over SSH to the target machine, -which then proceeds with the build; upon success the output(s) of the -build are copied back to the initial machine. +present.}. When that feature is enabled, a list of user-specified build +machines is read from @file{/etc/guix/machines.scm}; every time a build +is requested, for instance via @code{guix build}, the daemon attempts to +offload it to one of the machines that satisfy the constraints of the +derivation, in particular its system types---e.g., @code{x86_64-linux}. +A single machine can have multiple system types, either because its +architecture natively supports it, via emulation (@pxref{Transparent +Emulation with QEMU}), or both. Missing prerequisites for the build are +copied over SSH to the target machine, which then proceeds with the +build; upon success the output(s) of the build are copied back to the +initial machine. The @file{/etc/guix/machines.scm} file typically looks like this: @lisp (list (build-machine (name "eightysix.example.org") - (system "x86_64-linux") + (systems (list "x86_64-linux" "i686-linux")) (host-key "ssh-ed25519 AAAAC3Nza@dots{}") (user "bob") (speed 2.)) ;incredibly fast! (build-machine (name "armeight.example.org") - (system "aarch64-linux") + (systems (list "aarch64-linux")) (host-key "ssh-rsa AAAAB3Nza@dots{}") (user "alice") (private-key @@ -1075,8 +1077,8 @@ The @file{/etc/guix/machines.scm} file typically looks like this: @noindent In the example above we specify a list of two build machines, one for -the @code{x86_64} architecture and one for the @code{aarch64} -architecture. +the @code{x86_64} and @code{i686} architectures and one for the +@code{aarch64} architecture. In fact, this file is---not surprisingly!---a Scheme file that is evaluated when the @code{offload} hook is started. Its return value @@ -1096,8 +1098,9 @@ builds. The important fields are: @item name The host name of the remote machine. -@item system -The system type of the remote machine---e.g., @code{"x86_64-linux"}. +@item systems +The system types the remote machine supports---e.g., @code{(list +"x86_64-linux" "i686-linux")}. @item user The user account to use when connecting to the remote machine over SSH. @@ -25025,7 +25028,7 @@ Maximum number of backup files to keep. Defaults to @samp{3} @end deftypevr - +@node Transparent Emulation with QEMU @subsubheading Transparent Emulation with QEMU @cindex emulation diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 20ae7a9469..a56701f07a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,14 +67,16 @@ (define-module (guix scripts offload) ;;; ;;; Code: - (define-record-type* build-machine make-build-machine build-machine? (name build-machine-name) ; string (port build-machine-port ; number (default 22)) - (system build-machine-system) ; string + (systems %build-machine-systems ; list of strings + (default #f)) ; drop default after system is removed + (system %build-machine-system ; deprecated + (default #f)) (user build-machine-user) ; string (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) @@ -91,6 +94,19 @@ (define-record-type* (features build-machine-features ; list of strings (default '()))) +;;; Deprecated. +(define (build-machine-system machine) + (warning (G_ "The 'system' field is deprecated, \ +please use 'systems' instead.~%")) + (%build-machine-system machine)) + +;;; TODO: Remove after the deprecated 'system' field is removed. +(define (build-machine-systems machine) + (or (%build-machine-systems machine) + (list (build-machine-system machine)) + (leave (G_ "The build-machine object lacks a value for its 'systems' +field.")))) + (define-record-type* build-requirements make-build-requirements build-requirements? @@ -359,8 +375,8 @@ (define store (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." - (and (string=? (build-requirements-system requirements) - (build-machine-system machine)) + (and (member (build-requirements-system requirements) + (build-machine-systems machine)) (lset<= string=? (build-requirements-features requirements) (build-machine-features machine)))) diff --git a/tests/offload.scm b/tests/offload.scm new file mode 100644 index 0000000000..5a5de4e8b9 --- /dev/null +++ b/tests/offload.scm @@ -0,0 +1,71 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Maxim Cournoyer +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (tests offload) + #:use-module (guix scripts offload) + #:use-module (srfi srfi-64)) + + +(test-begin "offload") + +(define-syntax-rule (expose-internal-definitions s1 s2 ...) + (begin + (define s1 (@@ (guix scripts offload) s1)) + (define s2 (@@ (guix scripts offload) s2)) ...)) + +(expose-internal-definitions machine-matches? + build-requirements-system + build-requirements-features + build-machine-system + build-machine-systems + %build-machine-system + %build-machine-systems + build-machine-features) + +(define (deprecated-build-machine system) + (build-machine + (name "m1") + (user "dummy") + (host-key "some-key") + (system system))) + +(define (new-build-machine systems) + (build-machine + (name "m1") + (user "dummy") + (host-key "some-key") + (systems systems))) + +;;; Test that deprecated build-machine definitions still work. +(test-assert (machine-matches? (deprecated-build-machine "i686-linux") + (build-requirements + (system "i686-linux")))) + + +(test-assert (machine-matches? (new-build-machine '("i686-linux")) + (build-requirements + (system "i686-linux")))) + +;;; A build machine can act as more than one system type, thanks to QEMU +;;; emulation. +(test-assert (machine-matches? (new-build-machine '("armhf-linux" + "aarch64-linux" + "i686-linux" + "x86_64-linux")) + (build-requirements + (system "armhf-linux")))) -- cgit v1.2.3