From c311089b0b19f094e44d3f858c29f77d757332d1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jun 2016 22:36:40 +0200 Subject: services: Add 'mcron-service'. * gnu/services/mcron.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/tests/base.scm (%mcron-os, %test-mcron): New variables. (run-mcron-test): New procedure. * doc/guix.texi (Scheduled Job Execution): New node. --- doc/guix.texi | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 0bb68bb477..7516d75b8d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -204,6 +204,7 @@ System Configuration Services * Base Services:: Essential system services. +* Scheduled Job Execution:: The mcron service. * Networking Services:: Network setup, SSH daemon, etc. * X Window:: Graphical display. * Desktop Services:: D-Bus and desktop services. @@ -7185,6 +7186,7 @@ declaration. @menu * Base Services:: Essential system services. +* Scheduled Job Execution:: The mcron service. * Networking Services:: Network setup, SSH daemon, etc. * X Window:: Graphical display. * Desktop Services:: D-Bus and desktop services. @@ -7463,6 +7465,82 @@ archive}). If that is not the case, the service will fail to start. @end deffn +@node Scheduled Job Execution +@subsubsection Scheduled Job Execution + +@cindex cron +@cindex scheduling jobs +The @code{(gnu services mcron)} module provides an interface to +GNU@tie{}mcron, a daemon to run jobs at scheduled times (@pxref{Top,,, +mcron, GNU@tie{}mcron}). GNU@tie{}mcron is similar to the traditional +Unix @command{cron} daemon; the main difference is that it is +implemented in Guile Scheme, which provides a lot of flexibility when +specifying the scheduling of jobs and their actions. + +For example, to define an operating system that runs the +@command{updatedb} (@pxref{Invoking updatedb,,, find, Finding Files}) +and the @command{guix gc} commands (@pxref{Invoking guix gc}) daily: + +@lisp +(use-modules (guix) (gnu) (gnu services mcron)) + +(define updatedb-job + ;; Run 'updatedb' at 3 AM every day. + #~(job '(next-hour '(3)) + "updatedb --prunepaths='/tmp /var/tmp /gnu/store'")) + +(define garbage-collector-job + ;; Collect garbage 5 minutes after midnight every day. + #~(job "5 0 * * *" ;Vixie cron syntax + "guix gc -F 1G")) + +(operating-system + ;; @dots{} + (services (cons (mcron-service (list garbage-collector-job + updatedb-job)) + %base-services))) +@end lisp + +@xref{Guile Syntax, mcron job specifications,, mcron, GNU@tie{}mcron}, +for more information on mcron job specifications. Below is the +reference of the mcron service. + +@deffn {Scheme Procedure} mcron-service @var{jobs} [#:mcron @var{mcron2}] +Return an mcron service running @var{mcron} that schedules @var{jobs}, a +list of gexps denoting mcron job specifications. + +This is a shorthand for: +@example + (service mcron-service-type + (mcron-configuration (mcron mcron) (jobs jobs))) +@end example +@end deffn + +@defvr {Scheme Variable} mcron-service-type +This is the type of the @code{mcron} service, whose value is an +@code{mcron-configuration} object. + +This service type can be the target of a service extension that provides +it additional job specifications (@pxref{Service Composition}). In +other words, it is possible to define services that provide addition +mcron jobs to run. +@end defvr + +@deftp {Data Type} mcron-configuration +Data type representing the configuration of mcron. + +@table @asis +@item @code{mcron} (default: @var{mcron2}) +The mcron package to use. + +@item @code{jobs} +This is a list of gexps (@pxref{G-Expressions}), where each gexp +corresponds to an mcron job specification (@pxref{Syntax, mcron job +specifications,, mcron, GNU@tie{}mcron}). +@end table +@end deftp + + @node Networking Services @subsubsection Networking Services -- cgit v1.2.3 From 0a2f2848d5f39e008397215e697e14335dcce7c1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jun 2016 22:53:42 +0200 Subject: doc: Document 'make check-system'. * doc/guix.texi (Running the Test Suite): Document 'make check-system'. --- doc/guix.texi | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 7516d75b8d..d6d16b4d45 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -620,6 +620,31 @@ Upon failure, please email @email{bug-guix@@gnu.org} and attach the as well as version numbers of the dependencies (@pxref{Requirements}) in your message. +Guix also comes with a whole-system test suite that tests complete +GuixSD operating system instances. It can only run on systems where +Guix is already installed, using: + +@example +make check-system +@end example + +@noindent +or, again, by defining @code{TESTS} to select a subset of tests to run: + +@example +make check-system TESTS="basic mcron" +@end example + +These system tests are defined in the @code{(gnu tests @dots{})} +modules. They work by running the operating systems under test with +lightweight instrumentation in a virtual machine (VM). They can be +computationally intensive or rather cheap, depending on whether +substitutes are available for their dependencies (@pxref{Substitutes}). +Some of them require a lot of storage space to hold VM images. + +Again in case of test failures, please send @email{bug-guix@@gnu.org} +all the details. + @node Setting Up the Daemon @section Setting Up the Daemon -- cgit v1.2.3 From eca69fc0d69585b6c261c621599e5d7e10034306 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Jun 2016 12:16:07 +0200 Subject: doc: Clarify /dev/kvm setup. Reported by myglc2 . * doc/guix.texi (Build Environment Setup): Mention the "kvm" group. (Invoking guix system): Use "@quotation Note" for the note about KVM; make it clear that KVM is optional. --- doc/guix.texi | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index d6d16b4d45..9e3806c845 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -708,8 +708,13 @@ Bash syntax and the @code{shadow} commands): @noindent The number of build users determines how many build jobs may run in parallel, as specified by the @option{--max-jobs} option -(@pxref{Invoking guix-daemon, @option{--max-jobs}}). The -@code{guix-daemon} program may then be run as @code{root} with the +(@pxref{Invoking guix-daemon, @option{--max-jobs}}). To use +@command{guix system vm} and related commands, you may need to add the +build users to the @code{kvm} group so they can access @file{/dev/kvm}, +using @code{-G guixbuild,kvm} instead of @code{-G guixbuild} +(@pxref{Invoking guix system}). + +The @code{guix-daemon} program may then be run as @code{root} with the following command@footnote{If your machine uses the systemd init system, dropping the @file{@var{prefix}/lib/systemd/system/guix-daemon.service} file in @file{/etc/systemd/system} will ensure that @@ -10224,12 +10229,14 @@ a list of available debugging commands. @end table @end table -Note that all the actions above, except @code{build} and @code{init}, -rely on KVM support in the Linux-Libre kernel. Specifically, the -machine should have hardware virtualization support, the corresponding +@quotation Note +All the actions above, except @code{build} and @code{init}, +can use KVM support in the Linux-libre kernel. Specifically, if the +machine has hardware virtualization support, the corresponding KVM kernel module should be loaded, and the @file{/dev/kvm} device node must exist and be readable and writable by the user and by the -build users of the daemon. +build users of the daemon (@pxref{Build Environment Setup}). +@end quotation Once you have built, configured, re-configured, and re-re-configured your GuixSD installation, you may find it useful to list the operating -- cgit v1.2.3 From 8ac6282c4b97ece43b922a8c1a99a0a8e753c765 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Jun 2016 15:27:34 +0200 Subject: doc: Augment mcron example. Suggested by Danny Milosavljevic. * doc/guix.texi (Scheduled Job Execution): Add unprivileged job example, and show the use of thunks as job actions and gexps. --- doc/guix.texi | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 9e3806c845..7204f2e939 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7507,27 +7507,45 @@ Unix @command{cron} daemon; the main difference is that it is implemented in Guile Scheme, which provides a lot of flexibility when specifying the scheduling of jobs and their actions. -For example, to define an operating system that runs the +The example below defines an operating system that runs the @command{updatedb} (@pxref{Invoking updatedb,,, find, Finding Files}) -and the @command{guix gc} commands (@pxref{Invoking guix gc}) daily: +and the @command{guix gc} commands (@pxref{Invoking guix gc}) daily, as +well as the @command{mkid} command on behalf of an unprivileged user +(@pxref{mkid invocation,,, idutils, ID Database Utilities}). It uses +gexps to introduce job definitions that are passed to mcron +(@pxref{G-Expressions}). @lisp (use-modules (guix) (gnu) (gnu services mcron)) +(use-package-modules base idutils) (define updatedb-job - ;; Run 'updatedb' at 3 AM every day. + ;; Run 'updatedb' at 3AM every day. Here we write the + ;; job's action as a Scheme procedure. #~(job '(next-hour '(3)) - "updatedb --prunepaths='/tmp /var/tmp /gnu/store'")) + (lambda () + (execl (string-append #$findutils "/bin/updatedb") + "updatedb" + "--prunepaths=/tmp /var/tmp /gnu/store")))) (define garbage-collector-job ;; Collect garbage 5 minutes after midnight every day. + ;; The job's action is a shell command. #~(job "5 0 * * *" ;Vixie cron syntax "guix gc -F 1G")) +(define idutils-jobs + ;; Update the index database as user "charlie" at 12:15PM + ;; and 19:15PM. This runs from the user's home directory. + #~(job '(next-minute-from (next-hour '(12 19)) '(15)) + (string-append #$idutils "/bin/mkid src") + #:user "charlie")) + (operating-system ;; @dots{} (services (cons (mcron-service (list garbage-collector-job - updatedb-job)) + updatedb-job + idutils-job)) %base-services))) @end lisp -- cgit v1.2.3 From b6683f15073d89e4d0cbde2b4f0f00e17777a917 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 19:09:04 +0200 Subject: doc: Fix typo for 'static-networking-service'. * doc/guix.texi (Networking Services): Change #:name-services to #:name-servers. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 7204f2e939..379c9f699b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7602,7 +7602,7 @@ Protocol (DHCP) client, on all the non-loopback network interfaces. @end deffn @deffn {Scheme Procedure} static-networking-service @var{interface} @var{ip} @ - [#:gateway #f] [#:name-services @code{'()}] + [#:gateway #f] [#:name-servers @code{'()}] Return a service that starts @var{interface} with address @var{ip}. If @var{gateway} is true, it must be a string specifying the default network gateway. -- cgit v1.2.3 From c8695f325dc96fb54b3a99711533ca8503c677e2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 21:35:46 +0200 Subject: services: avahi: Add #:debug? parameter. * gnu/services/avahi.scm ()[debug?]: New field. (avahi-shepherd-service): Honor it. (avahi-service): Add #:debug? and honor it. * doc/guix.texi (Networking Services): Adjust accordingly. --- doc/guix.texi | 2 +- gnu/services/avahi.scm | 11 ++++++++--- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 379c9f699b..62c0d34805 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7767,7 +7767,7 @@ The @code{(gnu services avahi)} provides the following definition. @deffn {Scheme Procedure} avahi-service [#:avahi @var{avahi}] @ [#:host-name #f] [#:publish? #t] [#:ipv4? #t] @ [#:ipv6? #t] [#:wide-area? #f] @ - [#:domains-to-browse '()] + [#:domains-to-browse '()] [#:debug? #f] Return a service that runs @command{avahi-daemon}, a system-wide mDNS/DNS-SD responder that allows for service discovery and "zero-configuration" host name lookups (see @uref{http://avahi.org/}), and diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 7c3bdabff6..562005c22c 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -42,6 +42,8 @@ (define-record-type* avahi-configuration? (avahi avahi-configuration-avahi ; (default avahi)) + (debug? avahi-configuration-debug? ;Boolean + (default #f)) (host-name avahi-configuration-host-name) ;string (publish? avahi-configuration-publish?) ;Boolean (ipv4? avahi-configuration-ipv4?) ;Boolean @@ -96,6 +98,7 @@ (define %avahi-activation (define (avahi-shepherd-service config) "Return a list of for CONFIG." (let ((config (configuration-file config)) + (debug? (avahi-configuration-debug? config)) (avahi (avahi-configuration-avahi config))) (list (shepherd-service (documentation "Run the Avahi mDNS/DNS-SD responder.") @@ -104,7 +107,9 @@ (define (avahi-shepherd-service config) (start #~(make-forkexec-constructor (list (string-append #$avahi "/sbin/avahi-daemon") - "--daemonize" "-f" #$config) + "--daemonize" + #$@(if debug? #~("--debug") #~()) + "-f" #$config) #:pid-file "/var/run/avahi-daemon/pid")) (stop #~(make-kill-destructor)))))) @@ -128,7 +133,7 @@ (define avahi-service-type (service-extension profile-service-type avahi-package)))))) -(define* (avahi-service #:key (avahi avahi) +(define* (avahi-service #:key (avahi avahi) debug? host-name (publish? #t) (ipv4? #t) (ipv6? #t) @@ -156,7 +161,7 @@ (define* (avahi-service #:key (avahi avahi) sockets." (service avahi-service-type (avahi-configuration - (avahi avahi) (host-name host-name) + (avahi avahi) (debug? debug?) (host-name host-name) (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?) (wide-area? wide-area?) (domains-to-browse domains-to-browse)))) -- cgit v1.2.3 From b58cbf9ac507f58ef3031305ce8c13ea889de2d2 Mon Sep 17 00:00:00 2001 From: David Craven Date: Sun, 3 Jul 2016 20:25:09 +0200 Subject: services: Add rngd-service. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/base.scm (): New record type. (rngd-service-type): New variable. (rngd-service): New procedure. * doc/guix.texi (Base Services): Document it. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 7 +++++++ gnu/services/base.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 52 insertions(+), 2 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 62c0d34805..c9d9bd8977 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7494,6 +7494,13 @@ created by @command{guix archive --generate-key} (@pxref{Invoking guix archive}). If that is not the case, the service will fail to start. @end deffn +@anchor{rngd-service} +@deffn {Scheme Procedure} rngd-service [#:rng-tools @var{rng-tools}] @ + [#:device "/dev/hwrng"] +Return a service that runs the @command{rngd} program from @var{rng-tools} +to add @var{device} to the kernel's entropy pool. The service will fail if +@var{device} does not exist. +@end deffn @node Scheduled Job Execution @subsubsection Scheduled Job Execution diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f304bf89a3..5eabfec423 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Sou Bunnbu ;;; Copyright © 2016 Leo Famulari +;;; Copyright © 2016 David Craven ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,7 @@ (define-module (gnu services base) #:use-module (gnu system mapped-devices) #:use-module (gnu packages admin) #:use-module ((gnu packages linux) - #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda gpm)) + #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools)) #:use-module ((gnu packages base) #:select (canonical-package glibc)) #:use-module (gnu packages package-management) @@ -97,6 +98,8 @@ (define-module (gnu services base) urandom-seed-service-type urandom-seed-service + rngd-service-type + rngd-service %base-services)) @@ -486,7 +489,47 @@ (define urandom-seed-service-type (define (urandom-seed-service) (service urandom-seed-service-type #f)) - + +;;; +;;; Add hardware random number generator to entropy pool. +;;; + +(define-record-type* + rngd-configuration make-rngd-configuration + rngd-configuration? + (rng-tools rngd-configuration-rng-tools) ;package + (device rngd-configuration-device)) ;string + +(define rngd-service-type + (shepherd-service-type + 'rngd + (lambda (config) + (define rng-tools (rngd-configuration-rng-tools config)) + (define device (rngd-configuration-device config)) + + (define rngd-command + (list #~(string-append #$rng-tools "/sbin/rngd") + "-f" "-r" device)) + + (shepherd-service + (documentation "Add TRNG to entropy pool.") + (requirement '(udev)) + (provision '(trng)) + (start #~(make-forkexec-constructor #$@rngd-command)) + (stop #~(make-kill-destructor)))))) + +(define* (rngd-service #:key + (rng-tools rng-tools) + (device "/dev/hwrng")) + "Return a service that runs the @command{rngd} program from @var{rng-tools} +to add @var{device} to the kernel's entropy pool. The service will fail if +@var{device} does not exist." + (service rngd-service-type + (rngd-configuration + (rng-tools rng-tools) + (device device)))) + + ;;; ;;; System-wide environment variables. ;;; -- cgit v1.2.3 From 0bb9929eaa3f963ae75478e789723f9e8582116b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Jul 2016 22:26:19 +0200 Subject: gexp: Add 'with-imported-modules' macro. * guix/gexp.scm ()[modules]: New field. (gexp-modules): New procedure. (gexp->derivation): Use it and append the result to %MODULES. Update docstring to mark #:modules as deprecated. (current-imported-modules, with-imported-modules): New macros. (gexp): Pass CURRENT-IMPORTED-MODULES as second argument to 'gexp'. (gexp->script): Use and honor 'gexp-modules'; define '%modules'. * tests/gexp.scm ("gexp->derivation & with-imported-modules") ("gexp->derivation & nested with-imported-modules") ("gexp-modules & ungexp", "gexp-modules & ungexp-splicing"): New tests. ("program-file"): Use 'with-imported-modules'. Remove #:modules argument to 'program-file'. * doc/guix.texi (G-Expressions): Document 'with-imported-modules'. Mark #:modules of 'gexp->derivation' as deprecated. * emacs/guix-devel.el: Add syntax for 'with-imported-modules'. (guix-devel-keywords): Add it. * .dir-locals.el: Likewise. --- .dir-locals.el | 1 + doc/guix.texi | 38 ++++++++++++++++++++++++++++++- emacs/guix-devel.el | 2 ++ guix/gexp.scm | 47 ++++++++++++++++++++++++++++++++++----- tests/gexp.scm | 64 +++++++++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 142 insertions(+), 10 deletions(-) (limited to 'doc') diff --git a/.dir-locals.el b/.dir-locals.el index 0873c1d747..c7ceb9e9f0 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -59,6 +59,7 @@ (eval . (put 'run-with-store 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) + (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index c9d9bd8977..b315325034 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3697,6 +3697,30 @@ In the example above, the native build of @var{coreutils} is used, so that @command{ln} can actually run on the host; but then the cross-compiled build of @var{emacs} is referenced. +@cindex imported modules, for gexps +@findex with-imported-modules +Another gexp feature is @dfn{imported modules}: sometimes you want to be +able to use certain Guile modules from the ``host environment'' in the +gexp, so those modules should be imported in the ``build environment''. +The @code{with-imported-modules} form allows you to express that: + +@example +(let ((build (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")))))) + (gexp->derivation "empty-dir" + #~(begin + #$build + (display "success!\n") + #t))) +@end example + +@noindent +In this example, the @code{(guix build utils)} module is automatically +pulled into the isolated build environment of our gexp, such that +@code{(use-modules (guix build utils))} works as expected. + The syntactic form to construct gexps is summarized below. @deffn {Scheme Syntax} #~@var{exp} @@ -3756,6 +3780,16 @@ G-expressions created by @code{gexp} or @code{#~} are run-time objects of the @code{gexp?} type (see below.) @end deffn +@deffn {Scheme Syntax} with-imported-modules @var{modules} @var{body}@dots{} +Mark the gexps defined in @var{body}@dots{} as requiring @var{modules} +in their execution environment. @var{modules} must be a list of Guile +module names, such as @code{'((guix build utils) (guix build gremlin))}. + +This form has @emph{lexical} scope: it has an effect on the gexps +directly defined in @var{body}@dots{}, but not on those defined, say, in +procedures called from @var{body}@dots{}. +@end deffn + @deffn {Scheme Procedure} gexp? @var{obj} Return @code{#t} if @var{obj} is a G-expression. @end deffn @@ -3781,7 +3815,9 @@ stored in a file called @var{script-name}. When @var{target} is true, it is used as the cross-compilation target triplet for packages referred to by @var{exp}. -Make @var{modules} available in the evaluation context of @var{exp}; +@var{modules} is deprecated in favor of @code{with-imported-modules}. +Its meaning is to +make @var{modules} available in the evaluation context of @var{exp}; @var{modules} is a list of names of Guile modules searched in @var{module-path} to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el index ee8371ce81..b71670cdfb 100644 --- a/emacs/guix-devel.el +++ b/emacs/guix-devel.el @@ -216,6 +216,7 @@ to find 'modify-phases' keywords." "with-derivation-substitute" "with-directory-excursion" "with-error-handling" + "with-imported-modules" "with-monad" "with-mutex" "with-store")) @@ -306,6 +307,7 @@ Each rule should have a form (SYMBOL VALUE). See `put' for details." (with-derivation-substitute 2) (with-directory-excursion 1) (with-error-handling 0) + (with-imported-modules 1) (with-monad 1) (with-mutex 1) (with-store 1) diff --git a/guix/gexp.scm b/guix/gexp.scm index c86f4d0fd3..e9274a05f4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -29,6 +29,7 @@ (define-module (guix gexp) #:use-module (ice-9 match) #:export (gexp gexp? + with-imported-modules gexp-input gexp-input? @@ -98,9 +99,10 @@ (define-module (guix gexp) ;; "G expressions". (define-record-type - (make-gexp references proc) + (make-gexp references modules proc) gexp? (references gexp-references) ;list of + (modules gexp-self-modules) ;list of module names (proc gexp-proc)) ;procedure (define (write-gexp gexp port) @@ -384,6 +386,23 @@ (define (write-gexp-output output port) (set-record-type-printer! write-gexp-output) +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on." + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ (? gexp? exp)) + (gexp-modules exp)) + (($ (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp))))) + (define raw-derivation (store-lift derivation)) @@ -465,7 +484,8 @@ (define* (gexp->derivation name exp TARGET is true, it is used as the cross-compilation target triplet for packages referred to by EXP. -Make MODULES available in the evaluation context of EXP; MODULES is a list of +MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to +make MODULES available in the evaluation context of EXP; MODULES is a list of names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). @@ -494,7 +514,9 @@ (define* (gexp->derivation name exp referenced by the outputs. The other arguments are as for 'derivation'." - (define %modules modules) + (define %modules + (delete-duplicates + (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) @@ -724,6 +746,17 @@ (define (syntax-location-string s) (simple-format #f "~a:~a" line column))) ""))) +(define-syntax-parameter current-imported-modules + ;; Current list of imported modules. + (identifier-syntax '())) + +(define-syntax-rule (with-imported-modules modules body ...) + "Mark the gexps defined in BODY... as requiring MODULES in their execution +environment." + (syntax-parameterize ((current-imported-modules + (identifier-syntax modules))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -819,6 +852,7 @@ (define (substitute-references exp substs) (sexp (substitute-references #'exp (zip escapes formals))) (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) + current-imported-modules (lambda #,formals #,sexp))))))) @@ -960,8 +994,11 @@ (define* (gexp->script name exp #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in its search path." - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules))) + (define %modules + (append (gexp-modules exp) modules)) + + (mlet %store-monad ((modules (imported-modules %modules)) + (compiled (compiled-modules %modules))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) diff --git a/tests/gexp.scm b/tests/gexp.scm index f44f0eaf9a..36ce66f7cc 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -526,6 +526,18 @@ (define (match-input thing) get-bytevector-all)))) files)))))) +(test-equal "gexp-modules & ungexp" + '((bar) (foo)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$(with-imported-modules '((foo)) #~+) + #+(with-imported-modules '((bar)) #~-)))) + +(test-equal "gexp-modules & ungexp-splicing" + '((foo) (bar)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$@(list (with-imported-modules '((foo)) #~+) + (with-imported-modules '((bar)) #~-))))) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin @@ -540,6 +552,50 @@ (define (match-input thing) (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) +(test-assertm "gexp->derivation & with-imported-modules" + ;; Same test as above, but using 'with-imported-modules'. + (mlet* %store-monad + ((build -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (drv (gexp->derivation "test-with-modules" build))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix")))) + (return (eq? (stat:type s) 'directory)))))) + +(test-assertm "gexp->derivation & nested with-imported-modules" + (mlet* %store-monad + ((build1 -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (build2 -> (with-imported-modules '((guix build bournish)) + #~(begin + (use-modules (guix build bournish) + (system base compile)) + #+build1 + (call-with-output-file (string-append #$output "/b") + (lambda (port) + (write + (read-and-compile (open-input-string "cd /foo") + #:from %bournish-language + #:to 'scheme) + port)))))) + (drv (gexp->derivation "test-with-modules" build2))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix"))) + (b (string-append p "/b"))) + (return (and (eq? (stat:type s) 'directory) + (equal? '(chdir "/foo") + (call-with-input-file b read)))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -676,11 +732,11 @@ (define shebang (test-assertm "program-file" (let* ((n (random (expt 2 50))) - (exp (gexp (begin - (use-modules (guix build utils)) - (display (ungexp n))))) + (exp (with-imported-modules '((guix build utils)) + (gexp (begin + (use-modules (guix build utils)) + (display (ungexp n)))))) (file (program-file "program" exp - #:modules '((guix build utils)) #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) -- cgit v1.2.3 From 4ee96a7912eef8c41c855c680f924dcdba2d9c97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Jul 2016 23:11:40 +0200 Subject: gnu: Switch to 'with-imported-modules'. * gnu/services.scm (directory-union): Use 'with-imported-modules' instead of the '#:modules' argument of 'computed-file'. * gnu/services/base.scm (udev-rules-union): Likewise. * gnu/services/dbus.scm (system-service-directory): Likewise. * gnu/services/desktop.scm (wrapped-dbus-service): (polkit-directory): Likewise. * gnu/services/networking.scm (tor-configuration->torrc): Likewise. * gnu/services/xorg.scm (xorg-configuration-directory): Likewise. * gnu/system/install.scm (self-contained-tarball): Likewise. * gnu/system/linux-container.scm (container-script): Likewise. * gnu/system/linux-initrd.scm (expression->initrd): Likewise, and remove #:modules parameter. (flat-linux-module-directory): Use 'with-imported-modules'. (base-initrd): Likewise. * gnu/system/locale.scm (locale-directory): Likewise. * gnu/system/shadow.scm (default-skeletons): Likewise. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise. * gnu/tests/base.scm (run-basic-test): Likewise. * gnu/tests/install.scm (run-install): Likewise. * doc/guix.texi (Initial RAM Disk): Update 'expression->initrd' documentation. --- doc/guix.texi | 6 +- gnu/services.scm | 8 +- gnu/services/base.scm | 60 ++--- gnu/services/dbus.scm | 41 ++-- gnu/services/desktop.scm | 67 +++--- gnu/services/networking.scm | 54 ++--- gnu/services/xorg.scm | 42 ++-- gnu/system/install.scm | 117 +++++----- gnu/system/linux-container.scm | 48 ++-- gnu/system/linux-initrd.scm | 170 +++++++------- gnu/system/locale.scm | 8 +- gnu/system/shadow.scm | 72 +++--- gnu/system/vm.scm | 46 ++-- gnu/tests/base.scm | 514 ++++++++++++++++++++--------------------- gnu/tests/install.scm | 82 +++---- 15 files changed, 665 insertions(+), 670 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index b315325034..a0014e7112 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10016,15 +10016,11 @@ program. That gives a lot of flexibility. The program to run in that initrd. @deffn {Monadic Procedure} expression->initrd @var{exp} @ - [#:guile %guile-static-stripped] [#:name "guile-initrd"] @ - [#:modules '()] + [#:guile %guile-static-stripped] [#:name "guile-initrd"] Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing @var{guile} and that evaluates @var{exp}, a G-expression, upon booting. All the derivations referenced by @var{exp} are automatically copied to the initrd. - -@var{modules} is a list of Guile module names to be embedded in the -initrd. @end deffn @node GRUB Configuration diff --git a/gnu/services.scm b/gnu/services.scm index 50e76df818..661835f68e 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -309,10 +309,10 @@ (define (directory-union name things) one) (_ (computed-file name - #~(begin - (use-modules (guix build union)) - (union-build #$output '#$things)) - #:modules '((guix build union)))))) + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + (union-build #$output '#$things))))))) (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5eabfec423..d9c60778a1 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1138,44 +1138,44 @@ (define (udev-rules-union packages) "Return the union of the @code{lib/udev/rules.d} directories found in each item of @var{packages}." (define build - #~(begin - (use-modules (guix build union) - (guix build utils) - (srfi srfi-1) - (srfi srfi-26)) + (with-imported-modules '((guix build union) + (guix build utils)) + #~(begin + (use-modules (guix build union) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) - (define %standard-locations - '("/lib/udev/rules.d" "/libexec/udev/rules.d")) + (define %standard-locations + '("/lib/udev/rules.d" "/libexec/udev/rules.d")) - (define (rules-sub-directory directory) - ;; Return the sub-directory of DIRECTORY containing udev rules, or - ;; #f if none was found. - (find directory-exists? - (map (cut string-append directory <>) %standard-locations))) + (define (rules-sub-directory directory) + ;; Return the sub-directory of DIRECTORY containing udev rules, or + ;; #f if none was found. + (find directory-exists? + (map (cut string-append directory <>) %standard-locations))) - (mkdir-p (string-append #$output "/lib/udev")) - (union-build (string-append #$output "/lib/udev/rules.d") - (filter-map rules-sub-directory '#$packages)))) + (mkdir-p (string-append #$output "/lib/udev")) + (union-build (string-append #$output "/lib/udev/rules.d") + (filter-map rules-sub-directory '#$packages))))) - (computed-file "udev-rules" build - #:modules '((guix build union) - (guix build utils)))) + (computed-file "udev-rules" build)) (define (udev-rule file-name contents) "Return a directory with a udev rule file FILE-NAME containing CONTENTS." (computed-file file-name - #~(begin - (use-modules (guix build utils)) - - (define rules.d - (string-append #$output "/lib/udev/rules.d")) - - (mkdir-p rules.d) - (call-with-output-file - (string-append rules.d "/" #$file-name) - (lambda (port) - (display #$contents port)))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define rules.d + (string-append #$output "/lib/udev/rules.d")) + + (mkdir-p rules.d) + (call-with-output-file + (string-append rules.d "/" #$file-name) + (lambda (port) + (display #$contents port))))))) (define kvm-udev-rule ;; Return a directory with a udev rule that changes the group of /dev/kvm to diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 9a4a13d41d..d06b2dde23 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -46,26 +46,27 @@ (define (system-service-directory services) "Return the system service directory, containing @code{.service} files for all the services that may be activated by the daemon." (computed-file "dbus-system-services" - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define files - (append-map (lambda (service) - (find-files (string-append - service - "/share/dbus-1/system-services") - "\\.service$")) - (list #$@services))) - - (mkdir #$output) - (for-each (lambda (file) - (symlink file - (string-append #$output "/" - (basename file)))) - files) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (service) + (find-files + (string-append + service + "/share/dbus-1/system-services") + "\\.service$")) + (list #$@services))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t)))) (define (dbus-configuration-directory services) "Return a directory contains the @code{system-local.conf} file for DBUS that diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 2fb08cd1b3..86214a73bf 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -91,30 +91,33 @@ (define wrapper (string-append #$service "/" #$program) (cdr (command-line)))))) + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))))) + (computed-file (string-append (package-name service) "-wrapper") - #~(begin - (use-modules (guix build utils)) - - (define service-directory - "/share/dbus-1/system-services") - - (mkdir-p (dirname (string-append #$output - service-directory))) - (copy-recursively (string-append #$service - service-directory) - (string-append #$output - service-directory)) - (symlink (string-append #$service "/etc") ;for etc/dbus-1 - (string-append #$output "/etc")) - - (for-each (lambda (file) - (substitute* file - (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" - _ original-program arguments) - (string-append "Exec=" #$wrapper arguments - "\n")))) - (find-files #$output "\\.service$"))) - #:modules '((guix build utils)))) + build)) ;;; @@ -408,15 +411,15 @@ (define %polkit-pam-services (define (polkit-directory packages) "Return a directory containing an @file{actions} and possibly a @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." - (computed-file "etc-polkit-1" - #~(begin - (use-modules (guix build union) (srfi srfi-26)) - - (union-build #$output - (map (cut string-append <> - "/share/polkit-1") - (list #$@packages)))) - #:modules '((guix build union)))) + (with-imported-modules '((guix build union)) + (computed-file "etc-polkit-1" + #~(begin + (use-modules (guix build union) (srfi srfi-26)) + + (union-build #$output + (map (cut string-append <> + "/share/polkit-1") + (list #$@packages))))))) (define polkit-etc-files (match-lambda diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index af2a60936b..a77ed3bb80 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2016 Efraim Flashner ;;; @@ -345,39 +345,39 @@ (define (tor-configuration->torrc config) (($ tor config-file services) (computed-file "torrc" - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (call-with-output-file #$output - (lambda (port) - (display "\ + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (call-with-output-file #$output + (lambda (port) + (display "\ # The beginning was automatically added. User tor DataDirectory /var/lib/tor Log notice syslog\n" port) - (for-each (match-lambda - ((service (ports hosts) ...) - (format port "\ + (for-each (match-lambda + ((service (ports hosts) ...) + (format port "\ HiddenServiceDir /var/lib/tor/hidden-services/~a~%" - service) - (for-each (lambda (tcp-port host) - (format port "\ + service) + (for-each (lambda (tcp-port host) + (format port "\ HiddenServicePort ~a ~a~%" - tcp-port host)) - ports hosts))) - '#$(map (match-lambda - (($ name mapping) - (cons name mapping))) - services)) - - ;; Append the user's config file. - (call-with-input-file #$config-file - (lambda (input) - (dump-port input port))) - #t))) - #:modules '((guix build utils)))))) + tcp-port host)) + ports hosts))) + '#$(map (match-lambda + (($ name mapping) + (cons name mapping))) + services)) + + ;; Append the user's config file. + (call-with-input-file #$config-file + (lambda (input) + (dump-port input port))) + #t)))))))) (define (tor-shepherd-service config) "Return a running TOR." diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 9908b9526b..44d12a7e77 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -158,27 +158,27 @@ (define (xorg-configuration-directory modules) "Return a directory that contains the @code{.conf} files for X.org that includes the @code{share/X11/xorg.conf.d} directories of each package listed in @var{modules}." - (computed-file "xorg.conf.d" - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define files - (append-map (lambda (module) - (find-files (string-append - module - "/share/X11/xorg.conf.d") - "\\.conf$")) - (list #$@modules))) - - (mkdir #$output) - (for-each (lambda (file) - (symlink file - (string-append #$output "/" - (basename file)))) - files) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + (computed-file "xorg.conf.d" + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (module) + (find-files (string-append + module + "/share/X11/xorg.conf.d") + "\\.conf$")) + (list #$@modules))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t)))) (define* (xorg-start-command #:key (guile (canonical-package guile-2.0)) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index de14f6fb4c..329c7aba32 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -55,52 +55,53 @@ (define* (self-contained-tarball #:key (guix guix)) (manifest (list (package->manifest-entry guix)))))) (define build - #~(begin - (use-modules (guix build utils) - (gnu build install)) - - (define %root "root") - - (setenv "PATH" - (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (zero? (system* "tar" "--xz" "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - "--sort=name" - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, - ;; so that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a different - ;; home directory. - "./var/guix" - (string-append "." (%store-directory))))))) + (with-imported-modules '((guix build utils) + (guix build store-copy) + (gnu build install)) + #~(begin + (use-modules (guix build utils) + (gnu build install)) + + (define %root "root") + + (setenv "PATH" + (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin")) + + ;; Note: there is not much to gain here with deduplication and + ;; there is the overhead of the '.links' directory, so turn it + ;; off. + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (zero? (system* "tar" "--xz" "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + "--sort=name" + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + "./var/guix" + (string-append "." (%store-directory)))))))) (gexp->derivation "guix-tarball.tar.xz" build - #:references-graphs `(("profile" ,profile)) - #:modules '((guix build utils) - (guix build store-copy) - (gnu build install))))) + #:references-graphs `(("profile" ,profile))))) (define (log-to-info) @@ -212,20 +213,20 @@ (define (file f) (define directory (computed-file "configuration-templates" - #~(begin - (mkdir #$output) - (for-each (lambda (file target) - (copy-file file - (string-append #$output "/" - target))) - '(#$(file "bare-bones.tmpl") - #$(file "desktop.tmpl") - #$(file "lightweight-desktop.tmpl")) - '("bare-bones.scm" - "desktop.scm" - "lightweight-desktop.scm")) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (mkdir #$output) + (for-each (lambda (file target) + (copy-file file + (string-append #$output "/" + target))) + '(#$(file "bare-bones.tmpl") + #$(file "desktop.tmpl") + #$(file "lightweight-desktop.tmpl")) + '("bare-bones.scm" + "desktop.scm" + "lightweight-desktop.scm")) + #t)))) `(("configuration" ,directory))) diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 3acc579a6b..2e20379473 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -87,30 +87,28 @@ (define* (container-script os #:key (mappings '())) #:container? #t))) (define script - #~(begin - (use-modules (gnu build linux-container) - (guix build utils)) + (with-imported-modules '((guix config) + (guix utils) + (guix build utils) + (guix build syscalls) + (guix build bournish) + (gnu build file-systems) + (gnu build linux-container)) + #~(begin + (use-modules (gnu build linux-container) + (guix build utils)) - (call-with-container '#$specs - (lambda () - (setenv "HOME" "/root") - (setenv "TMPDIR" "/tmp") - (setenv "GUIX_NEW_SYSTEM" #$os-drv) - (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) - (primitive-load (string-append #$os-drv "/boot"))) - ;; A range of 65536 uid/gids is used to cover 16 bits worth of - ;; users and groups, which is sufficient for most cases. - ;; - ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= - #:host-uids 65536))) + (call-with-container '#$specs + (lambda () + (setenv "HOME" "/root") + (setenv "TMPDIR" "/tmp") + (setenv "GUIX_NEW_SYSTEM" #$os-drv) + (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) + (primitive-load (string-append #$os-drv "/boot"))) + ;; A range of 65536 uid/gids is used to cover 16 bits worth of + ;; users and groups, which is sufficient for most cases. + ;; + ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= + #:host-uids 65536)))) - (gexp->script "run-container" script - #:modules '((ice-9 match) - (srfi srfi-98) - (guix config) - (guix utils) - (guix build utils) - (guix build syscalls) - (guix build bournish) - (gnu build file-systems) - (gnu build linux-container)))))) + (gexp->script "run-container" script)))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8339fae7ed..bbaa5c0f89 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -55,85 +55,81 @@ (define* (expression->initrd exp (guile %guile-static-stripped) (gzip gzip) (name "guile-initrd") - (system (%current-system)) - (modules '())) + (system (%current-system))) "Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP, a G-expression, upon booting. All -the derivations referenced by EXP are automatically copied to the initrd. - -MODULES is a list of Guile module names to be embedded in the initrd." +the derivations referenced by EXP are automatically copied to the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. (mlet %store-monad ((init (gexp->script "init" exp - #:modules modules #:guile guile))) (define builder - #~(begin - (use-modules (gnu build linux-initrd)) + (with-imported-modules '((guix cpio) + (guix build utils) + (guix build store-copy) + (gnu build linux-initrd)) + #~(begin + (use-modules (gnu build linux-initrd)) - (mkdir #$output) - (build-initrd (string-append #$output "/initrd") - #:guile #$guile - #:init #$init - ;; Copy everything INIT refers to into the initrd. - #:references-graphs '("closure") - #:gzip (string-append #$gzip "/bin/gzip")))) + (mkdir #$output) + (build-initrd (string-append #$output "/initrd") + #:guile #$guile + #:init #$init + ;; Copy everything INIT refers to into the initrd. + #:references-graphs '("closure") + #:gzip (string-append #$gzip "/bin/gzip"))))) - (gexp->derivation name builder - #:modules '((guix cpio) - (guix build utils) - (guix build store-copy) - (gnu build linux-initrd)) - #:references-graphs `(("closure" ,init))))) + (gexp->derivation name builder + #:references-graphs `(("closure" ,init))))) (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." (define build-exp - #~(begin - (use-modules (ice-9 match) (ice-9 regex) - (srfi srfi-1) - (guix build utils) - (gnu build linux-modules)) + (with-imported-modules '((guix build utils) + (guix elf) + (gnu build linux-modules)) + #~(begin + (use-modules (ice-9 match) (ice-9 regex) + (srfi srfi-1) + (guix build utils) + (gnu build linux-modules)) - (define (string->regexp str) - ;; Return a regexp that matches STR exactly. - (string-append "^" (regexp-quote str) "$")) + (define (string->regexp str) + ;; Return a regexp that matches STR exactly. + (string-append "^" (regexp-quote str) "$")) - (define module-dir - (string-append #$linux "/lib/modules")) + (define module-dir + (string-append #$linux "/lib/modules")) - (define (lookup module) - (let ((name (ensure-dot-ko module))) - (match (find-files module-dir (string->regexp name)) - ((file) - file) - (() - (error "module not found" name module-dir)) - ((_ ...) - (error "several modules by that name" - name module-dir))))) + (define (lookup module) + (let ((name (ensure-dot-ko module))) + (match (find-files module-dir (string->regexp name)) + ((file) + file) + (() + (error "module not found" name module-dir)) + ((_ ...) + (error "several modules by that name" + name module-dir))))) - (define modules - (let ((modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) + (define modules + (let ((modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies modules + #:lookup-module lookup)))) - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules)))) + (mkdir #$output) + (for-each (lambda (module) + (format #t "copying '~a'...~%" module) + (copy-file module + (string-append #$output "/" + (basename module)))) + (delete-duplicates modules))))) - (gexp->derivation "linux-modules" build-exp - #:modules '((guix build utils) - (guix elf) - (gnu build linux-modules)))) + (gexp->derivation "linux-modules" build-exp)) (define* (base-initrd file-systems #:key @@ -227,38 +223,38 @@ (define device-mapping-commands (mlet %store-monad ((kodir (flat-linux-module-directory linux linux-modules))) (expression->initrd - #~(begin - (use-modules (gnu build linux-boot) - (guix build utils) - (guix build bournish) ;add the 'bournish' meta-command - (srfi srfi-26) + (with-imported-modules '((guix build bournish) + (guix build utils) + (guix build syscalls) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (guix elf)) + #~(begin + (use-modules (gnu build linux-boot) + (guix build utils) + (guix build bournish) ;add the 'bournish' meta-command + (srfi srfi-26) - ;; FIXME: The following modules are for - ;; LUKS-DEVICE-MAPPING. We should instead propagate - ;; this info via gexps. - ((gnu build file-systems) - #:select (find-partition-by-luks-uuid)) - (rnrs bytevectors)) + ;; FIXME: The following modules are for + ;; LUKS-DEVICE-MAPPING. We should instead propagate + ;; this info via gexps. + ((gnu build file-systems) + #:select (find-partition-by-luks-uuid)) + (rnrs bytevectors)) - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" '("bin" "sbin") - '#$helper-packages))) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) - (boot-system #:mounts '#$(map file-system->spec file-systems) - #:pre-mount (lambda () - (and #$@device-mapping-commands)) - #:linux-modules '#$linux-modules - #:linux-module-directory '#$kodir - #:qemu-guest-networking? #$qemu-networking? - #:volatile-root? '#$volatile-root?)) - #:name "base-initrd" - #:modules '((guix build bournish) - (guix build utils) - (guix build syscalls) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix elf))))) + (boot-system #:mounts '#$(map file-system->spec file-systems) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root?))) + #:name "base-initrd"))) ;;; linux-initrd.scm ends here diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm index f9d713e0cf..3bb9f950a8 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -154,10 +154,10 @@ (define* (locale-directory locales #:libc libc)) libcs))) (gexp->derivation "locale-multiple-versions" - #~(begin - (use-modules (guix build union)) - (union-build #$output (list #$@dirs))) - #:modules '((guix build union)) + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + (union-build #$output (list #$@dirs)))) #:local-build? #t #:substitutable? #f))))) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index b8837c63f0..730a9ee091 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -139,10 +139,11 @@ (define fonts.conf-content `(fontconfig (dir "/run/current-system/profile/share/fonts"))) (define copy-guile-wm - #~(begin - (use-modules (guix build utils)) - (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) - #$output))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + #$output)))) (let ((profile (plain-file "bash_profile" "\ # Honor per-interactive-shell startup file @@ -176,27 +177,26 @@ (define copy-guile-wm (zlogin (plain-file "zlogin" "\ # Honor system-wide environment variables source /etc/profile\n")) - (guile-wm (computed-file "guile-wm" copy-guile-wm - #:modules '((guix build utils)))) + (guile-wm (computed-file "guile-wm" copy-guile-wm)) (xdefaults (plain-file "Xdefaults" "\ XTerm*utf8: always XTerm*metaSendsEscape: true\n")) (fonts.conf (computed-file "fonts.conf" - #~(begin - (use-modules (guix build utils) - (sxml simple)) - - (define dir - (string-append #$output - "/fontconfig")) - - (mkdir-p dir) - (call-with-output-file (string-append dir - "/fonts.conf") - (lambda (port) - (sxml->xml '#$fonts.conf-content port)))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (sxml simple)) + + (define dir + (string-append #$output + "/fontconfig")) + + (mkdir-p dir) + (call-with-output-file (string-append dir + "/fonts.conf") + (lambda (port) + (sxml->xml '#$fonts.conf-content port))))))) (gdbinit (plain-file "gdbinit" "\ # Tell GDB where to look for separate debugging files. set debug-file-directory ~/.guix-profile/lib/debug\n"))) @@ -211,22 +211,22 @@ (define dir (define (skeleton-directory skeletons) "Return a directory containing SKELETONS, a list of name/derivation tuples." (computed-file "skel" - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-recursively source target))) - '#$skeletons) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-recursively source target))) + '#$skeletons) + #t)))) (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 676e89df98..fc5eaf5706 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -155,34 +155,34 @@ (define* (expression->derivation-in-linux-vm name exp (define builder ;; Code that launches the VM that evaluates EXP. - #~(begin - (use-modules (guix build utils) - (gnu build vm)) - - (let ((inputs '#$(list qemu coreutils)) - (linux (string-append #$linux "/bzImage")) - (initrd (string-append #$initrd "/initrd")) - (loader #$loader) - (graphs '#$(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f)))) - - (set-path-environment-variable "PATH" '("bin") inputs) - - (load-in-linux-vm loader - #:output #$output - #:linux linux #:initrd initrd - #:memory-size #$memory-size - #:make-disk-image? #$make-disk-image? - #:disk-image-format #$disk-image-format - #:disk-image-size #$disk-image-size - #:references-graphs graphs)))) + (with-imported-modules modules + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + + (let ((inputs '#$(list qemu coreutils)) + (linux (string-append #$linux "/bzImage")) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f)))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:disk-image-format #$disk-image-format + #:disk-image-size #$disk-image-size + #:references-graphs graphs))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 0013b465b4..a6278b25d4 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -70,125 +70,125 @@ (define* (run-basic-test os command #:optional (name "basic")) using COMMAND, a gexp that evaluates to a list of strings. Compare some properties of running system to what's declared in OS, an ." (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-1) - (srfi srfi-26) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette #$command)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "basic") - - (test-assert "uname" - (match (marionette-eval '(uname) marionette) - (#("Linux" host-name version _ architecture) - (and (string=? host-name - #$(operating-system-host-name os)) - (string-prefix? #$(package-version - (operating-system-kernel os)) - version) - (string-prefix? architecture %host-type))))) - - (test-assert "shell and user commands" - ;; Is everything in $PATH? - (zero? (marionette-eval '(system " + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-1) + (srfi srfi-26) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette #$command)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "basic") + + (test-assert "uname" + (match (marionette-eval '(uname) marionette) + (#("Linux" host-name version _ architecture) + (and (string=? host-name + #$(operating-system-host-name os)) + (string-prefix? #$(package-version + (operating-system-kernel os)) + version) + (string-prefix? architecture %host-type))))) + + (test-assert "shell and user commands" + ;; Is everything in $PATH? + (zero? (marionette-eval '(system " . /etc/profile set -e -x guix --version ls --version grep --version info --version") - marionette))) - - (test-assert "accounts" - (let ((users (marionette-eval '(begin - (use-modules (ice-9 match)) - (let loop ((result '())) - (match (getpw) - (#f (reverse result)) - (x (loop (cons x result)))))) - marionette))) - (lset= string=? - (map passwd:name users) - (list - #$@(map user-account-name - (operating-system-user-accounts os)))))) - - (test-assert "shepherd services" - (let ((services (marionette-eval '(begin - (use-modules (gnu services herd)) - (call-with-values current-services - append)) - marionette))) - (lset= eq? - (pk 'services services) - '(root #$@(operating-system-shepherd-service-names os))))) - - (test-equal "login on tty1" - "root\n" - (begin - (marionette-control "sendkey ctrl-alt-f1" marionette) - ;; Wait for the 'term-tty1' service to be running (using - ;; 'start-service' is the simplest and most reliable way to do - ;; that.) + marionette))) + + (test-assert "accounts" + (let ((users (marionette-eval '(begin + (use-modules (ice-9 match)) + (let loop ((result '())) + (match (getpw) + (#f (reverse result)) + (x (loop (cons x result)))))) + marionette))) + (lset= string=? + (map passwd:name users) + (list + #$@(map user-account-name + (operating-system-user-accounts os)))))) + + (test-assert "shepherd services" + (let ((services (marionette-eval '(begin + (use-modules (gnu services herd)) + (call-with-values current-services + append)) + marionette))) + (lset= eq? + (pk 'services services) + '(root #$@(operating-system-shepherd-service-names os))))) + + (test-equal "login on tty1" + "root\n" + (begin + (marionette-control "sendkey ctrl-alt-f1" marionette) + ;; Wait for the 'term-tty1' service to be running (using + ;; 'start-service' is the simplest and most reliable way to do + ;; that.) + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'term-tty1)) + marionette) + + ;; Now we can type. + (marionette-type "root\n\nid -un > logged-in\n" marionette) + + ;; It can take a while before the shell commands are executed. + (let loop ((i 0)) + (unless (or (file-exists? "/root/logged-in") (> i 15)) + (sleep 1) + (loop (+ i 1)))) + (marionette-eval '(use-modules (rnrs io ports)) marionette) + (marionette-eval '(call-with-input-file "/root/logged-in" + get-string-all) + marionette))) + + (test-assert "host name resolution" + (match (marionette-eval + '(begin + ;; Wait for nscd or our requests go through it. + (use-modules (gnu services herd)) + (start-service 'nscd) + + (list (getaddrinfo "localhost") + (getaddrinfo #$(operating-system-host-name os)))) + marionette) + ((((? vector?) ..1) ((? vector?) ..1)) + #t) + (x + (pk 'failure x #f)))) + + (test-equal "host not found" + #f (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'term-tty1)) - marionette) - - ;; Now we can type. - (marionette-type "root\n\nid -un > logged-in\n" marionette) - - ;; It can take a while before the shell commands are executed. - (let loop ((i 0)) - (unless (or (file-exists? "/root/logged-in") (> i 15)) - (sleep 1) - (loop (+ i 1)))) - (marionette-eval '(use-modules (rnrs io ports)) marionette) - (marionette-eval '(call-with-input-file "/root/logged-in" - get-string-all) - marionette))) - - (test-assert "host name resolution" - (match (marionette-eval - '(begin - ;; Wait for nscd or our requests go through it. - (use-modules (gnu services herd)) - (start-service 'nscd) - - (list (getaddrinfo "localhost") - (getaddrinfo #$(operating-system-host-name os)))) - marionette) - ((((? vector?) ..1) ((? vector?) ..1)) - #t) - (x - (pk 'failure x #f)))) - - (test-equal "host not found" - #f - (marionette-eval - '(false-if-exception (getaddrinfo "does-not-exist")) - marionette)) - - (test-assert "screendump" - (begin - (marionette-control (string-append "screendump " #$output - "/tty1.ppm") - marionette) - (file-exists? "tty1.ppm"))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation name test - #:modules '((gnu build marionette)))) + '(false-if-exception (getaddrinfo "does-not-exist")) + marionette)) + + (test-assert "screendump" + (begin + (marionette-control (string-append "screendump " #$output + "/tty1.ppm") + marionette) + (file-exists? "tty1.ppm"))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test)) (define %test-basic-os (system-test @@ -243,67 +243,67 @@ (define (run-mcron-test name) (command (system-qemu-image/shared-store-script os #:graphic? #f))) (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette (list #$command))) - - (define (wait-for-file file) - ;; Wait until FILE exists in the guest; 'read' its content and - ;; return it. - (marionette-eval - `(let loop ((i 10)) - (cond ((file-exists? ,file) - (call-with-input-file ,file read)) - ((> i 0) - (sleep 1) - (loop (- i 1))) - (else - (error "file didn't show up" ,file)))) - marionette)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "mcron") - - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'mcron) - 'running!) - marionette)) - - ;; Make sure root's mcron job runs, has its cwd set to "/root", and - ;; runs with the right UID/GID. - (test-equal "root's job" - '(0 0) - (wait-for-file "/root/witness")) - - ;; Likewise for Alice's job. We cannot know what its GID is since - ;; it's chosen by 'groupadd', but it's strictly positive. - (test-assert "alice's job" - (match (wait-for-file "/home/alice/witness") - ((1000 gid) - (>= gid 100)))) - - ;; Last, the job that uses a command; allows us to test whether - ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects - ;; that don't have a read syntax, hence the string.) - (test-equal "root's job with command" - "#" - (wait-for-file "/root/witness-touch")) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation name test - #:modules '((gnu build marionette))))) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette (list #$command))) + + (define (wait-for-file file) + ;; Wait until FILE exists in the guest; 'read' its content and + ;; return it. + (marionette-eval + `(let loop ((i 10)) + (cond ((file-exists? ,file) + (call-with-input-file ,file read)) + ((> i 0) + (sleep 1) + (loop (- i 1))) + (else + (error "file didn't show up" ,file)))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "mcron") + + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'mcron) + 'running!) + marionette)) + + ;; Make sure root's mcron job runs, has its cwd set to "/root", and + ;; runs with the right UID/GID. + (test-equal "root's job" + '(0 0) + (wait-for-file "/root/witness")) + + ;; Likewise for Alice's job. We cannot know what its GID is since + ;; it's chosen by 'groupadd', but it's strictly positive. + (test-assert "alice's job" + (match (wait-for-file "/home/alice/witness") + ((1000 gid) + (>= gid 100)))) + + ;; Last, the job that uses a command; allows us to test whether + ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects + ;; that don't have a read syntax, hence the string.) + (test-equal "root's job with command" + "#" + (wait-for-file "/root/witness-touch")) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test))) (define %test-mcron (system-test @@ -355,90 +355,90 @@ (define mdns-host-name ".local")) (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-1) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette (list #$run))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "avahi") - - (test-assert "wait for services" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - - (start-service 'nscd) - - ;; XXX: Work around a race condition in nscd: nscd creates its - ;; PID file before it is listening on its socket. - (let ((sock (socket PF_UNIX SOCK_STREAM 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock AF_UNIX "/var/run/nscd/socket") - (close-port sock) - (format #t "nscd is ready~%")) - (lambda args - (format #t "waiting for nscd...~%") - (usleep 500000) - (try))))) - - ;; Wait for the other useful things. - (start-service 'avahi-daemon) - (start-service 'networking) - - #t) - marionette)) - - (test-equal "avahi-resolve-host-name" - 0 - (marionette-eval - '(system* - "/run/current-system/profile/bin/avahi-resolve-host-name" - "-v" #$mdns-host-name) - marionette)) - - (test-equal "avahi-browse" - 0 - (marionette-eval - '(system* "avahi-browse" "-avt") - marionette)) - - (test-assert "getaddrinfo .local" - ;; Wait for the 'avahi-daemon' service and perform a resolution. - (match (marionette-eval - '(getaddrinfo #$mdns-host-name) - marionette) - (((? vector? addrinfos) ..1) - (pk 'getaddrinfo addrinfos) - (and (any (lambda (ai) - (= AF_INET (addrinfo:fam ai))) - addrinfos) - (any (lambda (ai) - (= AF_INET6 (addrinfo:fam ai))) - addrinfos))))) - - (test-assert "gethostbyname .local" - (match (pk 'gethostbyname - (marionette-eval '(gethostbyname #$mdns-host-name) - marionette)) - ((? vector? result) - (and (string=? (hostent:name result) #$mdns-host-name) - (= (hostent:addrtype result) AF_INET))))) - - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation "nss-mdns" test - #:modules '((gnu build marionette))))) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-1) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette (list #$run))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "avahi") + + (test-assert "wait for services" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + + (start-service 'nscd) + + ;; XXX: Work around a race condition in nscd: nscd creates its + ;; PID file before it is listening on its socket. + (let ((sock (socket PF_UNIX SOCK_STREAM 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock AF_UNIX "/var/run/nscd/socket") + (close-port sock) + (format #t "nscd is ready~%")) + (lambda args + (format #t "waiting for nscd...~%") + (usleep 500000) + (try))))) + + ;; Wait for the other useful things. + (start-service 'avahi-daemon) + (start-service 'networking) + + #t) + marionette)) + + (test-equal "avahi-resolve-host-name" + 0 + (marionette-eval + '(system* + "/run/current-system/profile/bin/avahi-resolve-host-name" + "-v" #$mdns-host-name) + marionette)) + + (test-equal "avahi-browse" + 0 + (marionette-eval + '(system* "avahi-browse" "-avt") + marionette)) + + (test-assert "getaddrinfo .local" + ;; Wait for the 'avahi-daemon' service and perform a resolution. + (match (marionette-eval + '(getaddrinfo #$mdns-host-name) + marionette) + (((? vector? addrinfos) ..1) + (pk 'getaddrinfo addrinfos) + (and (any (lambda (ai) + (= AF_INET (addrinfo:fam ai))) + addrinfos) + (any (lambda (ai) + (= AF_INET6 (addrinfo:fam ai))) + addrinfos))))) + + (test-assert "gethostbyname .local" + (match (pk 'gethostbyname + (marionette-eval '(gethostbyname #$mdns-host-name) + marionette)) + ((? vector? result) + (and (string=? (hostent:name result) #$mdns-host-name) + (= (hostent:addrtype result) AF_INET))))) + + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "nss-mdns" test))) (define %test-nss-mdns (system-test diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 2c0db41d69..3c83da151a 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -119,43 +119,45 @@ (define* (run-install #:key os (list target)) #:disk-image-size (* 1500 MiB)))) (define install - #~(begin - (use-modules (guix build utils) - (gnu build marionette)) - - (set-path-environment-variable "PATH" '("bin") - (list #$qemu-minimal)) - - (system* "qemu-img" "create" "-f" "qcow2" - #$output #$(number->string target-size)) - - (define marionette - (make-marionette - (cons (which #$(qemu-command system)) - (cons* "-no-reboot" "-m" "800" - "-drive" - (string-append "file=" #$image - ",if=virtio,readonly") - "-drive" - (string-append "file=" #$output ",if=virtio") - (if (file-exists? "/dev/kvm") - '("-enable-kvm") - '()))))) - - (pk 'uname (marionette-eval '(uname) marionette)) - - ;; Wait for tty1. - (marionette-eval '(begin - (use-modules (gnu services herd)) - (start 'term-tty1)) - marionette) - - (marionette-eval '(call-with-output-file "/etc/litl-config.scm" - (lambda (port) - (write '#$%minimal-os-source port))) - marionette) - - (exit (marionette-eval '(zero? (system " + (with-imported-modules '((guix build utils) + (gnu build marionette)) + #~(begin + (use-modules (guix build utils) + (gnu build marionette)) + + (set-path-environment-variable "PATH" '("bin") + (list #$qemu-minimal)) + + (system* "qemu-img" "create" "-f" "qcow2" + #$output #$(number->string target-size)) + + (define marionette + (make-marionette + (cons (which #$(qemu-command system)) + (cons* "-no-reboot" "-m" "800" + "-drive" + (string-append "file=" #$image + ",if=virtio,readonly") + "-drive" + (string-append "file=" #$output ",if=virtio") + (if (file-exists? "/dev/kvm") + '("-enable-kvm") + '()))))) + + (pk 'uname (marionette-eval '(uname) marionette)) + + ;; Wait for tty1. + (marionette-eval '(begin + (use-modules (gnu services herd)) + (start 'term-tty1)) + marionette) + + (marionette-eval '(call-with-output-file "/etc/litl-config.scm" + (lambda (port) + (write '#$%minimal-os-source port))) + marionette) + + (exit (marionette-eval '(zero? (system " . /etc/profile set -e -x; guix --version @@ -178,11 +180,9 @@ (define marionette guix system init /mnt/etc/config.scm /mnt --no-substitutes sync reboot\n")) - marionette)))) + marionette))))) - (gexp->derivation "installation" install - #:modules '((guix build utils) - (gnu build marionette))))) + (gexp->derivation "installation" install))) (define %test-installed-os -- cgit v1.2.3 From 2b4185792d3ec9b43a5c1bb204b6846e5ac0f14a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Jul 2016 23:54:18 +0200 Subject: gexp: 'gexp->file' emits code to set '%load-path'. * guix/gexp.scm (gexp->file): Add #:set-load-path? parameter and honor it. * gnu/system.scm (operating-system-parameters-file): Pass #:set-load-path? #f. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 6 +++++- gnu/system.scm | 3 ++- guix/gexp.scm | 32 +++++++++++++++++++++++--------- 3 files changed, 30 insertions(+), 11 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a0014e7112..abd294e886 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3943,8 +3943,12 @@ script, and @var{modules} is the list of modules visible to that script. This is the declarative counterpart of @code{gexp->script}. @end deffn -@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} +@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} @ + [#:set-load-path? #t] Return a derivation that builds a file @var{name} containing @var{exp}. +When @var{set-load-path?} is true, emit code in the resulting file to +set @code{%load-path} and @code{%load-compiled-path} to honor +@var{exp}'s imported modules. The resulting file holds references to all the dependencies of @var{exp} or a subset thereof. diff --git a/gnu/system.scm b/gnu/system.scm index 96ea153cd0..a49b3f29b3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -731,7 +731,8 @@ (define (operating-system-parameters-file os) (kernel #$(operating-system-kernel os)) (kernel-arguments #$(operating-system-kernel-arguments os)) - (initrd #$initrd))))) + (initrd #$initrd)) + #:set-load-path? #f))) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index e76a281bba..60f8905ea4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1026,15 +1026,29 @@ (define %modules (write '(ungexp exp) port) (chmod port #o555))))))) -(define (gexp->file name exp) - "Return a derivation that builds a file NAME containing EXP." - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp exp) port)))) - #:local-build? #t - #:substitutable? #f)) +(define* (gexp->file name exp #:key (set-load-path? #t)) + "Return a derivation that builds a file NAME containing EXP. When +SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' +and '%load-compiled-path' to honor EXP's imported modules." + (match (if set-load-path? (gexp-modules exp) '()) + (() ;zero modules + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f)) + ((modules ...) + (mlet %store-monad ((set-load-path (load-path-expression modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f))))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing -- cgit v1.2.3 From a91c3fc727ba90d8c9b91f67fb672da2e6b877ad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 00:38:50 +0200 Subject: services: no longer has an 'imported-modules' field. * gnu/services/shepherd.scm ()[imported-modules]: Remove. (%default-imported-modules): Make private. (shepherd-service-file): Use 'with-imported-modules'. (shepherd-configuration-file): Remove 'modules' and the calls to 'imported-modules' and 'compiled-modules'. Use 'with-imported-modules' instead. * doc/guix.texi (Shepherd Services): Adjust accordingly. * gnu/services/base.scm (file-system-shepherd-service): Use 'with-imported-modules'. Remove 'imported-modules' field. * gnu/system/mapped-devices.scm (device-mapping-service-type): Remove 'imported-modules'. (open-luks-device): Use 'with-imported-modules'. * gnu/tests.scm (marionette-shepherd-service): Remove 'imported-modules' field and use 'with-imported-modules'. --- doc/guix.texi | 4 -- gnu/services/base.scm | 105 ++++++++++++++++++------------------ gnu/services/shepherd.scm | 43 +++++---------- gnu/system/mapped-devices.scm | 34 ++++++------ gnu/tests.scm | 122 +++++++++++++++++++++--------------------- 5 files changed, 144 insertions(+), 164 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index abd294e886..37e854dc59 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10848,10 +10848,6 @@ where @var{service-name} is one of the symbols in @var{provision} This is the list of modules that must be in scope when @code{start} and @code{stop} are evaluated. -@item @code{imported-modules} (default: @var{%default-imported-modules}) -This is the list of modules to import in the execution environment of -the Shepherd. - @end table @end deftp diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d9c60778a1..02e3b41904 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -229,59 +229,58 @@ (define (file-system-shepherd-service file-system) (create? (file-system-create-mount-point? file-system)) (dependencies (file-system-dependencies file-system))) (if (file-system-mount? file-system) - (list - (shepherd-service - (provision (list (file-system->shepherd-service-name file-system))) - (requirement `(root-file-system - ,@(map dependency->shepherd-service-name dependencies))) - (documentation "Check, mount, and unmount the given file system.") - (start #~(lambda args - ;; FIXME: Use or factorize with 'mount-file-system'. - (let ((device (canonicalize-device-spec #$device '#$title)) - (flags #$(mount-flags->bit-mask - (file-system-flags file-system)))) - #$(if create? - #~(mkdir-p #$target) - #~#t) - #$(if check? - #~(begin - ;; Make sure fsck.ext2 & co. can be found. - (setenv "PATH" - (string-append - #$e2fsprogs "/sbin:" - "/run/current-system/profile/sbin:" - (getenv "PATH"))) - (check-file-system device #$type)) - #~#t) - - (mount device #$target #$type flags - #$(file-system-options file-system)) - - ;; For read-only bind mounts, an extra remount is - ;; needed, as per , - ;; which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (mount device #$target #$type - (logior MS_BIND MS_REMOUNT MS_RDONLY)))) - #t)) - (stop #~(lambda args - ;; Normally there are no processes left at this point, so - ;; TARGET can be safely unmounted. - - ;; Make sure PID 1 doesn't keep TARGET busy. - (chdir "/") - - (umount #$target) - #f)) - - ;; We need an additional module. - (modules `(((gnu build file-systems) - #:select (check-file-system canonicalize-device-spec)) - ,@%default-modules)) - (imported-modules `((gnu build file-systems) - (guix build bournish) - ,@%default-imported-modules)))) + (with-imported-modules '((gnu build file-systems) + (guix build bournish)) + (list + (shepherd-service + (provision (list (file-system->shepherd-service-name file-system))) + (requirement `(root-file-system + ,@(map dependency->shepherd-service-name dependencies))) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + ;; FIXME: Use or factorize with 'mount-file-system'. + (let ((device (canonicalize-device-spec #$device '#$title)) + (flags #$(mount-flags->bit-mask + (file-system-flags file-system)))) + #$(if create? + #~(mkdir-p #$target) + #~#t) + #$(if check? + #~(begin + ;; Make sure fsck.ext2 & co. can be found. + (setenv "PATH" + (string-append + #$e2fsprogs "/sbin:" + "/run/current-system/profile/sbin:" + (getenv "PATH"))) + (check-file-system device #$type)) + #~#t) + + (mount device #$target #$type flags + #$(file-system-options file-system)) + + ;; For read-only bind mounts, an extra remount is + ;; needed, as per , + ;; which still applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (mount device #$target #$type + (logior MS_BIND MS_REMOUNT MS_RDONLY)))) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + + ;; Make sure PID 1 doesn't keep TARGET busy. + (chdir "/") + + (umount #$target) + #f)) + + ;; We need an additional module. + (modules `(((gnu build file-systems) + #:select (check-file-system canonicalize-device-spec)) + ,@%default-modules))))) '()))) (define file-system-service-type diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 5d829e4c38..f35a6bf10a 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -47,9 +47,7 @@ (define-module (gnu services shepherd) shepherd-service-stop shepherd-service-auto-start? shepherd-service-modules - shepherd-service-imported-modules - %default-imported-modules %default-modules shepherd-service-file @@ -138,9 +136,7 @@ (define-record-type* (auto-start? shepherd-service-auto-start? ;Boolean (default #t)) (modules shepherd-service-modules ;list of module names - (default %default-modules)) - (imported-modules shepherd-service-imported-modules ;list of module names - (default %default-imported-modules))) + (default %default-modules))) (define (shepherd-service-canonical-name service) "Return the 'canonical name' of SERVICE." @@ -203,37 +199,26 @@ (define (shepherd-service-file-name service) (define (shepherd-service-file service) "Return a file defining SERVICE." (gexp->file (shepherd-service-file-name service) - #~(begin - (use-modules #$@(shepherd-service-modules service)) - - (make - #:docstring '#$(shepherd-service-documentation service) - #:provides '#$(shepherd-service-provision service) - #:requires '#$(shepherd-service-requirement service) - #:respawn? '#$(shepherd-service-respawn? service) - #:start #$(shepherd-service-start service) - #:stop #$(shepherd-service-stop service))))) + (with-imported-modules %default-imported-modules + #~(begin + (use-modules #$@(shepherd-service-modules service)) + + (make + #:docstring '#$(shepherd-service-documentation service) + #:provides '#$(shepherd-service-provision service) + #:requires '#$(shepherd-service-requirement service) + #:respawn? '#$(shepherd-service-respawn? service) + #:start #$(shepherd-service-start service) + #:stop #$(shepherd-service-stop service)))))) (define (shepherd-configuration-file services) "Return the shepherd configuration file for SERVICES." - (define modules - (delete-duplicates - (append-map shepherd-service-imported-modules services))) - (assert-valid-graph services) - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules)) - (files (mapm %store-monad - shepherd-service-file - services))) + (mlet %store-monad ((files (mapm %store-monad + shepherd-service-file services))) (define config #~(begin - (eval-when (expand load eval) - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - (use-modules (srfi srfi-34) (system repl error-handling)) diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 450b4737ac..732f73cc4b 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -85,9 +85,7 @@ (define device-mapping-service-type (modules `((rnrs bytevectors) ;bytevector? ((gnu build file-systems) #:select (find-partition-by-luks-uuid)) - ,@%default-modules)) - (imported-modules `((gnu build file-systems) - ,@%default-imported-modules))))))) + ,@%default-modules))))))) (define (device-mapping-service mapped-device) "Return a service that sets up @var{mapped-device}." @@ -101,20 +99,22 @@ (define (device-mapping-service mapped-device) (define (open-luks-device source target) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'." - #~(let ((source #$source)) - (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") - "open" "--type" "luks" - - ;; Note: We cannot use the "UUID=source" syntax here - ;; because 'cryptsetup' implements it by searching the - ;; udev-populated /dev/disk/by-id directory but udev may - ;; be unavailable at the time we run this. - (if (bytevector? source) - (or (find-partition-by-luks-uuid source) - (error "LUKS partition not found" source)) - source) - - #$target)))) + (with-imported-modules '((gnu build file-systems) + (guix build bournish)) + #~(let ((source #$source)) + (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + "open" "--type" "luks" + + ;; Note: We cannot use the "UUID=source" syntax here + ;; because 'cryptsetup' implements it by searching the + ;; udev-populated /dev/disk/by-id directory but udev may + ;; be unavailable at the time we run this. + (if (bytevector? source) + (or (find-partition-by-luks-uuid source) + (error "LUKS partition not found" source)) + source) + + #$target))))) (define (close-luks-device source target) "Return a gexp that closes TARGET, a LUKS device." diff --git a/gnu/tests.scm b/gnu/tests.scm index 1821ac45c5..8abe6c608b 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -80,68 +80,68 @@ (define (marionette-shepherd-service config) (srfi srfi-9 gnu) (guix build syscalls) (rnrs bytevectors))) - (imported-modules `((guix build syscalls) - ,@imported-modules)) (start - #~(lambda () - (define (clear-echo termios) - (set-field termios (termios-local-flags) - (logand (lognot (local-flags ECHO)) - (termios-local-flags termios)))) - - (define (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (let* ((repl (open-file #$device "r+0")) - (termios (tcgetattr (fileno repl))) - (console (open-file "/dev/console" "r+0"))) - ;; Don't echo input back. - (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) - (clear-echo termios)) - - ;; Redirect output to the console. - (close-fdes 1) - (close-fdes 2) - (dup2 (fileno console) 1) - (dup2 (fileno console) 2) - (close-port console) - - (display 'ready repl) - (let loop () - (newline repl) - - (match (read repl) - ((? eof-object?) - (primitive-exit 0)) - (expr - (catch #t - (lambda () - (let ((result (primitive-eval expr))) - (write (if (self-quoting? result) - result - (object->string result)) - repl))) - (lambda (key . args) - (print-exception (current-error-port) - (stack-ref (make-stack #t) 1) - key args) - (write #f repl))))) - (loop)))) - (lambda () - (primitive-exit 1)))) - (pid - pid)))) + (with-imported-modules `((guix build syscalls) + ,@imported-modules) + #~(lambda () + (define (clear-echo termios) + (set-field termios (termios-local-flags) + (logand (lognot (local-flags ECHO)) + (termios-local-flags termios)))) + + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (let* ((repl (open-file #$device "r+0")) + (termios (tcgetattr (fileno repl))) + (console (open-file "/dev/console" "r+0"))) + ;; Don't echo input back. + (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) + (clear-echo termios)) + + ;; Redirect output to the console. + (close-fdes 1) + (close-fdes 2) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + (close-port console) + + (display 'ready repl) + (let loop () + (newline repl) + + (match (read repl) + ((? eof-object?) + (primitive-exit 0)) + (expr + (catch #t + (lambda () + (let ((result (primitive-eval expr))) + (write (if (self-quoting? result) + result + (object->string result)) + repl))) + (lambda (key . args) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 1) + key args) + (write #f repl))))) + (loop)))) + (lambda () + (primitive-exit 1)))) + (pid + pid))))) (stop #~(make-kill-destructor))))))) (define marionette-service-type -- cgit v1.2.3 From a769bffb65d6ddfc108a4904641b310029f4924f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 17:43:19 +0200 Subject: gexp: 'computed-file' no longer has a #:modules parameter. * guix/gexp.scm ()[modules]: Remove. (computed-file): Remove #:modules. (computed-file-compiler): Likewise. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 5 ++--- guix/gexp.scm | 15 ++++++--------- 2 files changed, 8 insertions(+), 12 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 37e854dc59..1a14ff9f0e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3898,10 +3898,9 @@ This is the declarative counterpart of @code{text-file}. @end deffn @deffn {Scheme Procedure} computed-file @var{name} @var{gexp} @ - [#:modules '()] [#:options '(#:local-build? #t)] + [#:options '(#:local-build? #t)] Return an object representing the store item @var{name}, a file or -directory computed by @var{gexp}. @var{modules} specifies the set of -modules visible in the execution context of @var{gexp}. @var{options} +directory computed by @var{gexp}. @var{options} is a list of additional arguments to pass to @code{gexp->derivation}. This is the declarative counterpart of @code{gexp->derivation}. diff --git a/guix/gexp.scm b/guix/gexp.scm index 60f8905ea4..ec4fe0896a 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -50,7 +50,6 @@ (define-module (guix gexp) computed-file? computed-file-name computed-file-gexp - computed-file-modules computed-file-options program-file @@ -273,30 +272,28 @@ (define-gexp-compiler (plain-file-compiler (file plain-file?) system target) (text-file name content references)))) (define-record-type - (%computed-file name gexp modules options) + (%computed-file name gexp options) computed-file? (name computed-file-name) ;string (gexp computed-file-gexp) ;gexp - (modules computed-file-modules) ;list of module names (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (modules '()) (options '(#:local-build? #t))) + #:key (options '(#:local-build? #t))) "Return an object representing the store item NAME, a file or directory -computed by GEXP. MODULES specifies the set of modules visible in the -execution context of GEXP. OPTIONS is a list of additional arguments to pass +computed by GEXP. OPTIONS is a list of additional arguments to pass to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp modules options)) + (%computed-file name gexp options)) (define-gexp-compiler (computed-file-compiler (file computed-file?) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. (match file - (($ name gexp modules options) - (apply gexp->derivation name gexp #:modules modules options)))) + (($ name gexp options) + (apply gexp->derivation name gexp options)))) (define-record-type (%program-file name gexp modules guile) -- cgit v1.2.3 From 9c14a487bb3813ec5a555536b6bd1c4160ebb042 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 17:57:28 +0200 Subject: gexp: 'program-file' and 'gexp->script' no longer have #:modules. * guix/gexp.scm ()[modules]: Remove. (program-file): Remove #:modules and adjust accordingly. (program-file-compiler): Likewise. (gexp->script): Likewise. --- doc/guix.texi | 6 +++--- guix/gexp.scm | 27 ++++++++++----------------- 2 files changed, 13 insertions(+), 20 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 1a14ff9f0e..6d424b23e0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3908,7 +3908,7 @@ This is the declarative counterpart of @code{gexp->derivation}. @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} Return an executable script @var{name} that runs @var{exp} using -@var{guile} with @var{modules} in its search path. +@var{guile}, with @var{exp}'s imported modules in its search path. The example below builds a script that simply invokes the @command{ls} command: @@ -3934,10 +3934,10 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @end deffn @deffn {Scheme Procedure} program-file @var{name} @var{exp} @ - [#:modules '()] [#:guile #f] + [#:guile #f] Return an object representing the executable store item @var{name} that runs @var{gexp}. @var{guile} is the Guile package used to execute that -script, and @var{modules} is the list of modules visible to that script. +script. This is the declarative counterpart of @code{gexp->script}. @end deffn diff --git a/guix/gexp.scm b/guix/gexp.scm index ec4fe0896a..302879fb42 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -56,7 +56,6 @@ (define-module (guix gexp) program-file? program-file-name program-file-gexp - program-file-modules program-file-guile scheme-file @@ -296,29 +295,25 @@ (define-gexp-compiler (computed-file-compiler (file computed-file?) (apply gexp->derivation name gexp options)))) (define-record-type - (%program-file name gexp modules guile) + (%program-file name gexp guile) program-file? (name program-file-name) ;string (gexp program-file-gexp) ;gexp - (modules program-file-modules) ;list of module names (guile program-file-guile)) ;package -(define* (program-file name gexp - #:key (modules '()) (guile #f)) +(define* (program-file name gexp #:key (guile #f)) "Return an object representing the executable store item NAME that runs -GEXP. GUILE is the Guile package used to execute that script, and MODULES is -the list of modules visible to that script. +GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." - (%program-file name gexp modules guile)) + (%program-file name gexp guile)) (define-gexp-compiler (program-file-compiler (file program-file?) system target) ;; Compile FILE by returning a derivation that builds the script. (match file - (($ name gexp modules guile) + (($ name gexp guile) (gexp->script name gexp - #:modules modules #:guile (or guile (default-guile)))))) (define-record-type @@ -1000,13 +995,11 @@ (define (load-path-expression modules) %load-compiled-path))))))) (define* (gexp->script name exp - #:key (modules '()) (guile (default-guile))) - "Return an executable script NAME that runs EXP using GUILE with MODULES in -its search path." - (define %modules - (append (gexp-modules exp) modules)) - - (mlet %store-monad ((set-load-path (load-path-expression %modules))) + #:key (guile (default-guile))) + "Return an executable script NAME that runs EXP using GUILE, with EXP's +imported modules in its search path." + (mlet %store-monad ((set-load-path + (load-path-expression (gexp-modules exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) -- cgit v1.2.3 From 1929fdba80ab2432d0a9c27633c94a79fb3bb170 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 22:23:12 +0200 Subject: packages: no longer has an 'imported-modules' field. * guix/packages.scm ()[imported-modules]: Remove. (patch-and-repack): Remove #:imported-modules. Use 'with-imported-modules'. Remove #:modules argument to 'gexp->derivation'. (origin->derivation): Adjust accordingly. * doc/guix.texi (origin Reference): Adjust accordingly. --- doc/guix.texi | 9 +-- guix/packages.scm | 209 ++++++++++++++++++++++++++---------------------------- 2 files changed, 105 insertions(+), 113 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 6d424b23e0..67ece1d23f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2697,8 +2697,9 @@ file name explicitly because the default is not very descriptive. A list of file names containing patches to be applied to the source. @item @code{snippet} (default: @code{#f}) -A quoted piece of code that will be run in the source directory to make -any modifications, which is sometimes more convenient than a patch. +A G-expression (@pxref{G-Expressions}) or S-expression that will be run +in the source directory. This is a convenient way to modify the source, +sometimes more convenient than a patch. @item @code{patch-flags} (default: @code{'("-p1")}) A list of command-line flags that should be passed to the @code{patch} @@ -2713,10 +2714,6 @@ such as GNU@tie{}Patch. A list of Guile modules that should be loaded during the patching process and while running the code in the @code{snippet} field. -@item @code{imported-modules} (default: @code{'()}) -The list of Guile modules to import in the patch derivation, for use by -the @code{snippet}. - @item @code{patch-guile} (default: @code{#f}) The Guile package that should be used in the patching process. When this is @code{#f}, a sensible default is used. diff --git a/guix/packages.scm b/guix/packages.scm index acb8f34417..bfb4c557ab 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -56,7 +56,6 @@ (define-module (guix packages) origin-patch-guile origin-snippet origin-modules - origin-imported-modules base32 package @@ -164,8 +163,7 @@ (define-record-type* (default #f)) (modules origin-modules ; list of module names (default '())) - (imported-modules origin-imported-modules ; list of module names - (default '())) + (patch-guile origin-patch-guile ; package or #f (default #f))) @@ -381,14 +379,13 @@ (define* (patch-and-repack source patches (snippet #f) (flags '("-p1")) (modules '()) - (imported-modules '()) (guile-for-build (%guile-for-build)) (system (%current-system))) "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and repack the tarball using the tools listed in INPUTS. When SNIPPET is true, it must be an s-expression that will run from within the directory where -SOURCE was unpacked, after all of PATCHES have been applied. MODULES and -IMPORTED-MODULES specify modules to use/import for use by SNIPPET." +SOURCE was unpacked, after all of PATCHES have been applied. MODULES +specifies modules in scope when evaluating SNIPPET." (define source-file-name ;; SOURCE is usually a derivation, but it could be a store file. (if (derivation? source) @@ -449,107 +446,107 @@ (define instantiate-patch (patches (sequence %store-monad (map instantiate-patch patches)))) (define build - #~(begin - (use-modules (ice-9 ftw) - (srfi srfi-1) - (guix build utils)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. During bootstrap we must cope with older versions. - (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - (define (apply-patch patch) - (format (current-error-port) "applying '~a'...~%" patch) - - ;; Use '--force' so that patches that do not apply perfectly are - ;; rejected. - (zero? (system* (string-append #+patch "/bin/patch") - "--force" #+@flags "--input" patch))) - - (define (first-file directory) - ;; Return the name of the first file in DIRECTORY. - (car (scandir directory - (lambda (name) - (not (member name '("." ".."))))))) - - ;; Encoding/decoding errors shouldn't be silent. - (fluid-set! %default-port-conversion-strategy 'error) - - (when #+locales - ;; First of all, install a UTF-8 locale so that UTF-8 file names - ;; are correctly interpreted. During bootstrap, LOCALES is #f. - (setenv "LOCPATH" - (string-append #+locales "/lib/locale/" - #+(and locales - (package-version locales)))) - (setlocale LC_ALL "en_US.utf8")) - - (setenv "PATH" (string-append #+xz "/bin" ":" - #+decomp "/bin")) - - ;; SOURCE may be either a directory or a tarball. - (and (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory) - #t) - #+(if (string=? decompression-type "unzip") - #~(zero? (system* "unzip" #+source)) - #~(zero? (system* (string-append #+tar "/bin/tar") - "xvf" #+source)))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (and (every apply-patch '#+patches) - #+@(if snippet - #~((let ((module (make-fresh-user-module))) - (module-use-interfaces! module - (map resolve-interface - '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module))) - #~()) - - (begin (chdir "..") #t) - - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (zero? (apply system* (string-append #+tar "/bin/tar") - "cvfa" #$output - ;; avoid non-determinism in the archive - "--mtime=@0" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list"))))))))) - - (let ((name (tarxz-name original-file-name)) - (modules (delete-duplicates (cons '(guix build utils) - imported-modules)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (ice-9 ftw) + (srfi srfi-1) + (guix build utils)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. During bootstrap we must cope with older versions. + (define tar-supports-sort? + (zero? (system* (string-append #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + (define (apply-patch patch) + (format (current-error-port) "applying '~a'...~%" patch) + + ;; Use '--force' so that patches that do not apply perfectly are + ;; rejected. + (zero? (system* (string-append #+patch "/bin/patch") + "--force" #+@flags "--input" patch))) + + (define (first-file directory) + ;; Return the name of the first file in DIRECTORY. + (car (scandir directory + (lambda (name) + (not (member name '("." ".."))))))) + + ;; Encoding/decoding errors shouldn't be silent. + (fluid-set! %default-port-conversion-strategy 'error) + + (when #+locales + ;; First of all, install a UTF-8 locale so that UTF-8 file names + ;; are correctly interpreted. During bootstrap, LOCALES is #f. + (setenv "LOCPATH" + (string-append #+locales "/lib/locale/" + #+(and locales + (package-version locales)))) + (setlocale LC_ALL "en_US.utf8")) + + (setenv "PATH" (string-append #+xz "/bin" ":" + #+decomp "/bin")) + + ;; SOURCE may be either a directory or a tarball. + (and (if (file-is-directory? #+source) + (let* ((store (%store-directory)) + (len (+ 1 (string-length store))) + (base (string-drop #+source len)) + (dash (string-index base #\-)) + (directory (string-drop base (+ 1 dash)))) + (mkdir directory) + (copy-recursively #+source directory) + #t) + #+(if (string=? decompression-type "unzip") + #~(zero? (system* "unzip" #+source)) + #~(zero? (system* (string-append #+tar "/bin/tar") + "xvf" #+source)))) + (let ((directory (first-file "."))) + (format (current-error-port) + "source is under '~a'~%" directory) + (chdir directory) + + (and (every apply-patch '#+patches) + #+@(if snippet + #~((let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module))) + #~()) + + (begin (chdir "..") #t) + + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + (zero? (apply system* + (string-append #+tar "/bin/tar") + "cvfa" #$output + ;; avoid non-determinism in the archive + "--mtime=@0" + "--owner=root:0" + "--group=root:0" + (if tar-supports-sort? + `("--sort=name" + ,directory) + '("--no-recursion" + "--files-from=.file_list")))))))))) + + (let ((name (tarxz-name original-file-name))) (gexp->derivation name build #:graft? #f #:system system - #:modules modules #:guile-for-build guile-for-build)))) (define (transitive-inputs inputs) @@ -1138,8 +1135,7 @@ (define* (origin->derivation origin ;; No patches, no snippet: this is a fixed-output derivation. (method uri 'sha256 sha256 name #:system system)) (($ uri method sha256 name (= force (patches ...)) snippet - (flags ...) inputs (modules ...) (imported-modules ...) - guile-for-build) + (flags ...) inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. (mlet %store-monad ((source (method uri 'sha256 sha256 name #:system system)) @@ -1153,7 +1149,6 @@ (define* (origin->derivation origin #:flags flags #:system system #:modules modules - #:imported-modules imported-modules #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) -- cgit v1.2.3 From db97a03a892c662f316c9fd6a497b4b2a18626b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jul 2016 23:51:17 +0200 Subject: doc: Explain 'guix hash -r' for Git checkouts. * doc/guix.texi (origin Reference): Add xref to "guix download" and "guix hash". (Invoking guix hash): Provide an example to compute the hash of a Git checkout. Co-authored-by: Troy Sankey --- doc/guix.texi | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 67ece1d23f..4b55473c93 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2669,6 +2669,7 @@ Examples include: download a file from the HTTP, HTTPS, or FTP URL specified in the @code{uri} field; +@vindex git-fetch @item @var{git-fetch} from @code{(guix git-download)} clone the Git version control repository, and check out the revision specified in the @code{uri} field as a @code{git-reference} object; a @@ -2686,6 +2687,10 @@ A bytevector containing the SHA-256 hash of the source. Typically the @code{base32} form is used here to generate the bytevector from a base-32 string. +You can obtain this information using @code{guix download} +(@pxref{Invoking guix download}) or @code{guix hash} (@pxref{Invoking +guix hash}). + @item @code{file-name} (default: @code{#f}) The file name under which the source code should be saved. When this is @code{#f}, a sensible default value will be used in most cases. In case @@ -4569,6 +4574,17 @@ hash (@pxref{Invoking guix archive}). @c FIXME: Replace xref above with xref to an ``Archive'' section when @c it exists. +@vindex git-fetch +As an example, here is how you would compute the hash of a Git checkout, +which is useful when using the @code{git-fetch} method (@pxref{origin +Reference}): + +@example +$ git clone http://example.org/foo.git +$ cd foo +$ rm -rf .git +$ guix hash -r . +@end example @end table @node Invoking guix import -- cgit v1.2.3 From 71b0601a97da9f12f76de0480c341e06acf8f2bc Mon Sep 17 00:00:00 2001 From: David Craven Date: Wed, 13 Jul 2016 18:13:12 +0200 Subject: services: Add 'dropbear-service'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/services/ssh.scm (): New record type. (dropbear-activation, dropbear-shepherd-service, dropbear-service): New procedures. (dropbear-service-type): New variable. * doc/guix.texi (Networking Services): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 43 ++++++++++++++++++++++- gnu/services/ssh.scm | 97 +++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 134 insertions(+), 6 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 4b55473c93..a2732deded 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7754,7 +7754,7 @@ In addition, @var{extra-settings} specifies a string to append to the configuration file. @end deffn -Furthermore, @code{(gnu services ssh)} provides the following service. +Furthermore, @code{(gnu services ssh)} provides the following services. @deffn {Scheme Procedure} lsh-service [#:host-key "/etc/lsh/host-key"] @ [#:daemonic? #t] [#:interfaces '()] [#:port-number 22] @ @@ -7792,6 +7792,47 @@ root. The other options should be self-descriptive. @end deffn +@deffn {Scheme Procedure} dropbear-service [@var{config}] +Run the @uref{https://matt.ucc.asn.au/dropbear/dropbear.html,Dropbear SSH +daemon} with the given @var{config}, a @code{} +object. + +For example, to specify a Dropbear service listening on port 1234, add +this call to the operating system's @code{services} field: + +@example +(dropbear-service (dropbear-configuration + (port-number 1234))) +@end example +@end deffn + +@deftp {Data Type} dropbear-configuration +This data type represents the configuration of a Dropbear SSH daemon. + +@table @asis +@item @code{dropbear} (default: @var{dropbear}) +The Dropbear package to use. + +@item @code{port-number} (default: 22) +The TCP port where the daemon waits for incoming connections. + +@item @code{syslog-output?} (default: @code{#t}) +Whether to enable syslog output. + +@item @code{pid-file} (default: @code{"/var/run/dropbear.pid"}) +File name of the daemon's PID file. + +@item @code{root-login?} (default: @code{#f}) +Whether to allow @code{root} logins. + +@item @code{allow-empty-passwords?} (default: @code{#f}) +Whether to allow empty passwords. + +@item @code{password-authentication?} (default: @code{#t}) +Whether to enable password-based authentication. +@end table +@end deftp + @defvr {Scheme Variable} %facebook-host-aliases This variable contains a string for use in @file{/etc/hosts} (@pxref{Host Names,,, libc, The GNU C Library Reference Manual}). Each diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 1eb9382a84..743b5e3805 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 David Craven ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,14 +18,19 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services ssh) - #:use-module (guix gexp) - #:use-module (guix records) + #:use-module (gnu packages ssh) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system pam) - #:use-module (gnu packages ssh) + #:use-module (guix gexp) + #:use-module (guix records) #:use-module (srfi srfi-26) - #:export (lsh-service)) + #:export (lsh-service + + dropbear-configuration + dropbear-configuration? + dropbear-service-type + dropbear-service)) ;;; Commentary: ;;; @@ -235,4 +241,85 @@ (define* (lsh-service #:key public-key-authentication?) (initialize? initialize?)))) + +;;; +;;; Dropbear. +;;; + +(define-record-type* + dropbear-configuration make-dropbear-configuration + dropbear-configuration? + (dropbear dropbear-configuration-dropbear + (default dropbear)) + (port-number dropbear-configuration-port-number + (default 22)) + (syslog-output? dropbear-configuration-syslog-output? + (default #t)) + (pid-file dropbear-configuration-pid-file + (default "/var/run/dropbear.pid")) + (root-login? dropbear-configuration-root-login? + (default #f)) + (allow-empty-passwords? dropbear-configuration-allow-empty-passwords? + (default #f)) + (password-authentication? dropbear-configuration-password-authentication? + (default #t))) + +(define (dropbear-activation config) + "Return the activation gexp for CONFIG." + #~(begin + (mkdir-p "/etc/dropbear"))) + +(define (dropbear-shepherd-service config) + "Return a for dropbear with CONFIG." + (define dropbear + (dropbear-configuration-dropbear config)) + + (define pid-file + (dropbear-configuration-pid-file config)) + + (define dropbear-command + #~(list (string-append #$dropbear "/sbin/dropbear") + + ;; '-R' allows host keys to be automatically generated upon first + ;; connection, at a time when /dev/urandom is more likely securely + ;; seeded. + "-F" "-R" + + "-p" #$(number->string (dropbear-configuration-port-number config)) + "-P" #$pid-file + #$@(if (dropbear-configuration-syslog-output? config) '() '("-E")) + #$@(if (dropbear-configuration-root-login? config) '() '("-w")) + #$@(if (dropbear-configuration-password-authentication? config) + '() + '("-s" "-g")) + #$@(if (dropbear-configuration-allow-empty-passwords? config) + '("-B") + '()))) + + (define requires + (if (dropbear-configuration-syslog-output? config) + '(networking syslogd) '(networking))) + + (list (shepherd-service + (documentation "Dropbear SSH server.") + (requirement requires) + (provision '(ssh-daemon)) + (start #~(make-forkexec-constructor #$dropbear-command + #:pid-file #$pid-file)) + (stop #~(make-kill-destructor))))) + +(define dropbear-service-type + (service-type (name 'dropbear) + (extensions + (list (service-extension shepherd-root-service-type + dropbear-shepherd-service) + (service-extension activation-service-type + dropbear-activation))))) + +(define* (dropbear-service #:optional (config (dropbear-configuration))) + "Run the @uref{https://matt.ucc.asn.au/dropbear/dropbear.html,Dropbear SSH +daemon} with the given @var{config}, a @code{} +object." + (service dropbear-service-type config)) + ;;; ssh.scm ends here -- cgit v1.2.3 From 4a1fc562ae5eedf40f6ae4eabe30580b0983b8f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 23:58:34 +0200 Subject: publish: Add '--compression'. * guix/scripts/publish.scm (show-help, %options): Add '--compression'. (): New record type. (%no-compression, %default-gzip-compression): New variables. (%default-options): Add 'compression' key. (narinfo-string): Add #:compression parameter and honor it. (render-narinfo): Likewise. (render-nar): Likewise. : Add call to 'declare-header!'. (swallow-zlib-error): New macro. (nar-response-port): New procedure. (http-write): Add call to 'force-output'. Use 'nar-response-port' instead of 'response-port'. Use 'swallow-zlib-error'. (make-request-handler): Add #:compression parameter and honor it. Add "nar/gzip" URL handler. (run-publish-server): Add #:compression parameter and honor it. (guix-publish): Honor --compression. * tests/publish.scm (http-get-port, wait-until-ready): New procedures. : Run main server with "-C0". Call 'wait-until-ready'. ("/nar/gzip/*", "/*.narinfo with compression"): New tests. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 12 ++++ guix/scripts/publish.scm | 163 ++++++++++++++++++++++++++++++++++++++++------- tests/publish.scm | 59 +++++++++++++++-- 3 files changed, 203 insertions(+), 31 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a2732deded..6e8fb483f2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5644,6 +5644,18 @@ accept connections from any interface. Change privileges to @var{user} as soon as possible---i.e., once the server socket is open and the signing key has been read. +@item --compression[=@var{level}] +@itemx -C [@var{level}] +Compress data using the given @var{level}. When @var{level} is zero, +disable compression. The range 1 to 9 corresponds to different gzip +compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). +The default is 3. + +Note compression occurs on the fly and the compressed streams are not +cached. Thus, to reduce load on the machine that runs @command{guix +publish}, it may be a good idea to choose a low compression level, or to +run @command{guix publish} behind a caching proxy. + @item --ttl=@var{ttl} Produce @code{Cache-Control} HTTP headers that advertise a time-to-live (TTL) of @var{ttl}. @var{ttl} must denote a duration: @code{5d} means 5 diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e419..3e1ecb9d1b 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -27,6 +27,7 @@ (define-module (guix scripts publish) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -45,6 +46,7 @@ (define-module (guix scripts publish) #:use-module (guix pk-crypto) #:use-module (guix store) #:use-module (guix serialization) + #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) #:export (guix-publish)) @@ -58,6 +60,9 @@ (define (show-help) --listen=HOST listen on the network interface for HOST")) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " + -C, --compression[=LEVEL] + compress archives at LEVEL")) (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " @@ -79,6 +84,20 @@ (define (getaddrinfo* host) (leave (_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) +;; Nar compression parameters. +(define-record-type + (compression type level) + compression? + (type compression-type) + (level compression-level)) + +(define %no-compression + (compression 'none 0)) + +(define %default-gzip-compression + ;; Since we compress on the fly, default to fast compression. + (compression 'gzip 3)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -102,6 +121,14 @@ (define %options (() (leave (_ "lookup of host '~a' returned nothing") name))))) + (option '(#\C "compression") #f #t + (lambda (opt name arg result) + (match (if arg (string->number* arg) 3) + (0 + (alist-cons 'compression %no-compression result)) + (level + (alist-cons 'compression (compression 'gzip level) + result))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -117,6 +144,12 @@ (define %options (define %default-options `((port . 8080) + + ;; Default to fast & low compression. + (compression . ,(if (zlib-available?) + %default-gzip-compression + %no-compression)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -152,12 +185,20 @@ (define (signed-string s) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store store-path key) +(define* (narinfo-string store store-path key + #:key (compression %no-compression)) "Generate a narinfo key/value string for STORE-PATH; an exception is raised -if STORE-PATH is invalid. The narinfo is signed with KEY." +if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The +narinfo is signed with KEY." (let* ((path-info (query-path-info store store-path)) - (url (encode-and-join-uri-path (list "nar" - (basename store-path)))) + (url (encode-and-join-uri-path + `("nar" + ,@(match compression + (($ 'none) + '()) + (($ type) + (list (symbol->string type)))) + ,(basename store-path)))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -166,13 +207,16 @@ (define (narinfo-string store store-path key) " ")) (deriver (path-info-deriver path-info)) (base-info (format #f - "StorePath: ~a + "\ +StorePath: ~a URL: ~a -Compression: none +Compression: ~a NarHash: sha256:~a NarSize: ~d References: ~a~%" - store-path url hash size references)) + store-path url + (compression-type compression) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -209,7 +253,8 @@ (define (render-nix-cache-info) (format port "~a: ~a~%" key value))) %nix-cache-info)))) -(define* (render-narinfo store request hash #:key ttl) +(define* (render-narinfo store request hash + #:key ttl (compression %no-compression)) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the 'Cache-Control' header. This allows 'guix substitute' to cache it for an @@ -222,18 +267,35 @@ (define* (render-narinfo store request hash #:key ttl) `((cache-control (max-age . ,ttl))) '())) (cut display - (narinfo-string store store-path (force %private-key)) - <>))))) - -(define (render-nar store request store-item) + (narinfo-string store store-path (force %private-key) + #:compression compression) + <>))))) + +;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; internal consumption: it allows us to pass the compression info to +;; 'http-write', as part of the workaround to . +(declare-header! "Guix-Nar-Compression" + (lambda (str) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) + compression? + (lambda (compression port) + (match compression + (($ type level) + (write `(compression ,type ,level) port))))) + +(define* (render-nar store request store-item + #:key (compression %no-compression)) "Render archive of the store path corresponding to STORE-ITEM." (let ((store-path (string-append %store-directory "/" store-item))) ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte ;; sequences. (if (valid-path? store store-path) - (values '((content-type . (application/x-nix-archive - (charset . "ISO-8859-1")))) + (values `((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))) + (guix-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; . @@ -282,6 +344,28 @@ (define-syntax-rule (swallow-EPIPE exp ...) (values) (apply throw args))))) +(define-syntax-rule (swallow-zlib-error exp ...) + "Swallow 'zlib-error' exceptions raised by EXP..." + (catch 'zlib-error + (lambda () + exp ...) + (const #f))) + +(define (nar-response-port response) + "Return a port on which to write the body of RESPONSE, the response of a +/nar request, according to COMPRESSION." + (match (assoc-ref (response-headers response) 'guix-nar-compression) + (($ 'gzip level) + ;; Note: We cannot used chunked encoding here because + ;; 'make-gzip-output-port' wants a file port. + (make-gzip-output-port (response-port response) + #:level level + #:buffer-size (* 64 1024))) + (($ 'none) + (response-port response)) + (#f + (response-port response)))) + (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." @@ -293,16 +377,20 @@ (define (http-write server client response body) (lambda () (let* ((response (write-response (sans-content-length response) client)) - (port (response-port response))) + (port (begin + (force-output client) + (nar-response-port response)))) ;; XXX: Given our ugly workaround for in ;; 'render-nar', BODY here is just the file name of the store item. ;; We call 'write-file' from here because we know that's the only ;; way to avoid building the whole nar in memory, which could ;; quickly become a real problem. As a bonus, we even do ;; sendfile(2) directly from the store files to the socket. - (swallow-EPIPE - (write-file (utf8->string body) port)) - (close-port port) + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port)) (values))))) (_ ;; Handle other responses sequentially. @@ -316,7 +404,10 @@ (define-server-impl concurrent-http-server http-write (@@ (web server http) http-close)) -(define* (make-request-handler store #:key narinfo-ttl) +(define* (make-request-handler store + #:key + narinfo-ttl + (compression %no-compression)) (lambda (request body) (format #t "~a ~a~%" (request-method request) @@ -330,16 +421,37 @@ (define* (make-request-handler store #:key narinfo-ttl) (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash #:ttl narinfo-ttl)) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:compression compression)) + + ;; Use different URLs depending on the compression type. This + ;; guarantees that /nar URLs remain valid even when 'guix publish' + ;; is restarted with different compression parameters. + ;; /nar/ (("nar" store-item) - (render-nar store request store-item)) + (render-nar store request store-item + #:compression %no-compression)) + ;; /nar/gzip/ + (("nar" "gzip" store-item) + (if (zlib-available?) + (render-nar store request store-item + #:compression + (match compression + (($ 'gzip) + compression) + (_ + %default-gzip-compression))) + (not-found request))) (_ (not-found request))) (not-found request)))) (define* (run-publish-server socket store - #:key narinfo-ttl) - (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl) + #:key (compression %no-compression) narinfo-ttl) + (run-server (make-request-handler store + #:narinfo-ttl narinfo-ttl + #:compression compression) concurrent-http-server `(#:socket ,socket))) @@ -378,6 +490,7 @@ (define (guix-publish . args) (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) + (compression (assoc-ref opts 'compression)) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -404,4 +517,6 @@ (define (guix-publish . args) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server socket store #:narinfo-ttl ttl))))) + (run-publish-server socket store + #:compression compression + #:narinfo-ttl ttl))))) diff --git a/tests/publish.scm b/tests/publish.scm index d6d537c58a..9bf181f1fc 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -28,12 +28,15 @@ (define-module (test-publish) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix base64) + #:use-module ((guix records) #:select (recutils->alist)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix pk-crypto) + #:use-module (guix zlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) @@ -52,20 +55,28 @@ (define (http-get-body uri) (call-with-values (lambda () (http-get uri)) (lambda (response body) body))) +(define (http-get-port uri) + (call-with-values (lambda () (http-get uri #:streaming? #t)) + (lambda (response port) port))) + (define (publish-uri route) (string-append "http://localhost:6789" route)) ;; Run a local publishing server in a separate thread. (call-with-new-thread (lambda () - (guix-publish "--port=6789"))) ; attempt to avoid port collision + (guix-publish "--port=6789" "-C0"))) ;attempt to avoid port collision + +(define (wait-until-ready port) + ;; Wait until the server is accepting connections. + (let ((conn (socket PF_INET SOCK_STREAM 0))) + (let loop () + (unless (false-if-exception + (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port)) + (loop))))) -;; Wait until the server is accepting connections. -(let ((conn (socket PF_INET SOCK_STREAM 0))) - (let loop () - (unless (false-if-exception - (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789)) - (loop)))) +;; Wait until the two servers are ready. +(wait-until-ready 6789) (test-begin "publish") @@ -145,6 +156,40 @@ (define (publish-uri route) (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 + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/gzip/" (basename %item)))))) + (call-with-gzip-input-port nar + (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))) + ("Compression" . "gzip")) + (let ((thread (call-with-new-thread + (lambda () + (guix-publish "--port=6799" "-C5"))))) + (wait-until-ready 6799) + (let* ((url (string-append "http://localhost:6799/" + (store-path-hash-part %item) ".narinfo")) + (body (http-get-port url))) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body))))) + (test-equal "/nar/ with properly encoded '+' sign" "Congrats!" (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) -- cgit v1.2.3 From 4591c02ea934313638629b33ea47a148a1c38b53 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 19 Jul 2016 19:04:10 +0200 Subject: doc: Mention zlib as an optional dependency. * doc/guix.texi (Requirements): Mention zlib. (Invoking guix publish): Fix typo. --- doc/guix.texi | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 6e8fb483f2..1c4d57c811 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -546,6 +546,10 @@ Installing allow you to use the @command{guix import pypi} command (@pxref{Invoking guix import}). It is of interest primarily for developers and not for casual users. + +@item +When @url{http://zlib.net, zlib} is available, @command{guix publish} +can compress build byproducts (@pxref{Invoking guix publish}). @end itemize Unless @code{--disable-daemon} was passed to @command{configure}, the @@ -5651,7 +5655,7 @@ disable compression. The range 1 to 9 corresponds to different gzip compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). The default is 3. -Note compression occurs on the fly and the compressed streams are not +Compression occurs on the fly and the compressed streams are not cached. Thus, to reduce load on the machine that runs @command{guix publish}, it may be a good idea to choose a low compression level, or to run @command{guix publish} behind a caching proxy. -- cgit v1.2.3 From 909147e43f8c9f8c9b9d33597d5dd83facca699c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 12 Oct 2015 07:11:51 +0200 Subject: services: Add pam-limits-service. * gnu/system/pam.scm (): New record type. (pam-limits-entry, pam-limits-entry->string): New procedures. * gnu/services/base.scm (pam-limits-service-type): New variable. (pam-limits-service): New procedure. * doc/guix.texi (Base Services): Document it. --- doc/guix.texi | 30 +++++++++++++++++++++++++ gnu/services/base.scm | 43 ++++++++++++++++++++++++++++++++++++ gnu/system/pam.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 134 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 1c4d57c811..7ea9ddfe35 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -17,6 +17,7 @@ Copyright @copyright{} 2015, 2016 Mathieu Lirzin@* Copyright @copyright{} 2014 Pierre-Antoine Rault@* Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/Kammer@* Copyright @copyright{} 2015, 2016 Leo Famulari@* +Copyright @copyright{} 2015, 2016 Ricardo Wurmus@* Copyright @copyright{} 2016 Ben Woodcroft@* Copyright @copyright{} 2016 Chris Marusich@* Copyright @copyright{} 2016 Efraim Flashner @@ -7570,6 +7571,35 @@ to add @var{device} to the kernel's entropy pool. The service will fail if @var{device} does not exist. @end deffn +@anchor{pam-limits-service} +@cindex session limits +@cindex ulimit +@cindex priority +@deffn {Scheme Procedure} pam-limits-service [#:limits @var{limits}] + +Return a service that installs a configuration file for the +@uref{http://linux-pam.org/Linux-PAM-html/sag-pam_limits.html, +@code{pam_limits} module}. The procedure optionally takes a list of +@code{pam-limits-entry} values, which can be used to specify +@code{ulimit} limits and nice priority limits to user sessions. + +The following limits definition sets two hard and soft limits for all +login sessions of users in the @code{realtime} group: + +@example +(pam-limits-service + (list + (pam-limits-entry "@@realtime" 'both 'rtprio 99) + (pam-limits-entry "@@realtime" 'both 'memlock 'unlimited))) +@end example + +The first entry increases the maximum realtime priority for +non-privileged processes; the second entry lifts any restriction of the +maximum address space that can be locked in memory. These settings are +commonly used for real-time audio systems. +@end deffn + + @node Scheduled Job Execution @subsubsection Scheduled Job Execution diff --git a/gnu/services/base.scm b/gnu/services/base.scm index c9c2594533..805ba7d12c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Sou Bunnbu ;;; Copyright © 2016 Leo Famulari ;;; Copyright © 2016 David Craven +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -100,6 +101,8 @@ (define-module (gnu services base) urandom-seed-service rngd-service-type rngd-service + pam-limits-service-type + pam-limits-service %base-services)) @@ -924,6 +927,46 @@ (define* (syslog-service #:key (config-file %default-syslog.conf)) information on the configuration file syntax." (service syslog-service-type config-file)) +(define pam-limits-service-type + (let ((security-limits + ;; Create /etc/security containing the provided "limits.conf" file. + (lambda (limits-file) + `(("security" + ,(computed-file + "security" + #~(begin + (mkdir #$output) + (stat #$limits-file) + (symlink #$limits-file + (string-append #$output "/limits.conf")))))))) + (pam-extension + (lambda (pam) + (let ((pam-limits (pam-entry + (control "required") + (module "pam_limits.so") + (arguments '("conf=/etc/security/limits.conf"))))) + (if (member (pam-service-name pam) + '("login" "su" "slim")) + (pam-service + (inherit pam) + (session (cons pam-limits + (pam-service-session pam)))) + pam))))) + (service-type + (name 'limits) + (extensions + (list (service-extension etc-service-type security-limits) + (service-extension pam-root-service-type + (lambda _ (list pam-extension)))))))) + +(define* (pam-limits-service #:optional (limits '())) + "Return a service that makes selected programs respect the list of +pam-limits-entry specified in LIMITS via pam_limits.so." + (service pam-limits-service-type + (plain-file "limits.conf" + (string-join (map pam-limits-entry->string limits) + "\n")))) + ;;; ;;; Guix services. diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm index 743039daf6..cd7a3427ed 100644 --- a/gnu/system/pam.scm +++ b/gnu/system/pam.scm @@ -23,6 +23,7 @@ (define-module (gnu system pam) #:use-module (gnu services) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module ((guix utils) #:select (%current-system)) @@ -38,6 +39,13 @@ (define-module (gnu system pam) pam-entry-module pam-entry-arguments + pam-limits-entry + pam-limits-entry-domain + pam-limits-entry-type + pam-limits-entry-item + pam-limits-entry-value + pam-limits-entry->string + pam-services->directory unix-pam-service base-pam-services @@ -76,6 +84,59 @@ (module pam-entry-module) ; file name (arguments pam-entry-arguments ; list of string-valued g-expressions (default '()))) +;; PAM limits entries are used by the pam_limits PAM module to set or override +;; limits on system resources for user sessions. The format is specified +;; here: http://linux-pam.org/Linux-PAM-html/sag-pam_limits.html +(define-record-type + (make-pam-limits-entry domain type item value) + pam-limits-entry? + (domain pam-limits-entry-domain) ; string + (type pam-limits-entry-type) ; symbol + (item pam-limits-entry-item) ; symbol + (value pam-limits-entry-value)) ; symbol or number + +(define (pam-limits-entry domain type item value) + "Construct a pam-limits-entry ensuring that the provided values are valid." + (define (valid? value) + (case item + ((priority) (number? value)) + ((nice) (and (number? value) + (>= value -20) + (<= value 19))) + (else (or (and (number? value) + (>= value -1)) + (member value '(unlimited infinity)))))) + (define items + (list 'core 'data 'fsize + 'memlock 'nofile 'rss + 'stack 'cpu 'nproc + 'as 'maxlogins 'maxsyslogins + 'priority 'locks 'sigpending + 'msgqueue 'nice 'rtprio)) + (when (not (member type '(hard soft both))) + (error "invalid limit type" type)) + (when (not (member item items)) + (error "invalid limit item" item)) + (when (not (valid? value)) + (error "invalid limit value" value)) + (make-pam-limits-entry domain type item value)) + +(define (pam-limits-entry->string entry) + "Convert a pam-limits-entry record to a string." + (match entry + (($ domain type item value) + (string-join (list domain + (if (eq? type 'both) + "-" + (symbol->string type)) + (symbol->string item) + (cond + ((symbol? value) + (symbol->string value)) + (else + (number->string value)))) + " ")))) + (define (pam-service->configuration service) "Return the derivation building the configuration file for SERVICE, to be dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." -- cgit v1.2.3