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. --- gnu/services/mcron.scm | 115 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100644 gnu/services/mcron.scm (limited to 'gnu/services') diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm new file mode 100644 index 0000000000..313c8364f8 --- /dev/null +++ b/gnu/services/mcron.scm @@ -0,0 +1,115 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu services mcron) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services shepherd) + #:autoload (gnu packages guile) (mcron2) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:export (mcron-configuration + mcron-configuration? + mcron-configuration-mcron + mcron-configuration-jobs + + mcron-service-type + mcron-service)) + +;;; Commentary: +;;; +;;; This module implements a service that to run instances of GNU mcron, a +;;; periodic job execution daemon. Example of a service: +;; +;; (service mcron-service-type +;; (mcron-configuration +;; (jobs (list #~(job next-second-from +;; (lambda () +;; (call-with-output-file "/dev/console" +;; (lambda (port) +;; (display "hello!\n" port))))))))) +;;; +;;; Code: + +(define-record-type* mcron-configuration + make-mcron-configuration + mcron-configuration? + (mcron mcron-configuration-mcron ;package + (default mcron2)) + (jobs mcron-configuration-jobs ;list of + (default '()))) + +(define (job-file job) + (scheme-file "mcron-job" job)) + +(define mcron-shepherd-services + (match-lambda + (($ mcron ()) ;nothing to do! + '()) + (($ mcron jobs) + (list (shepherd-service + (provision '(mcron)) + (requirement '(user-processes)) + (modules `((srfi srfi-1) + (srfi srfi-26) + ,@%default-modules)) + (start #~(make-forkexec-constructor + (list (string-append #$mcron "/bin/mcron") + #$@(map job-file jobs)) + + ;; Disable auto-compilation of the job files and set a + ;; sane value for 'PATH'. + #:environment-variables + (cons* "GUILE_AUTO_COMPILE=0" + "PATH=/run/current-system/profile/bin" + (remove (cut string-prefix? "PATH=" <>) + (environ))))) + (stop #~(make-kill-destructor))))))) + +(define mcron-service-type + (service-type (name 'mcron) + (extensions + (list (service-extension shepherd-root-service-type + mcron-shepherd-services) + (service-extension profile-service-type + (compose list + mcron-configuration-mcron)))) + (compose concatenate) + (extend (lambda (config jobs) + (mcron-configuration + (inherit config) + (jobs (append (mcron-configuration-jobs config) + jobs))))))) + +(define* (mcron-service jobs #:optional (mcron 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 +" + (service mcron-service-type + (mcron-configuration (mcron mcron) (jobs jobs)))) + +;;; mcron.scm ends here -- cgit v1.2.3 From 04101d99eeaad0867ed886e52049af1b6a5ec487 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 20:57:35 +0200 Subject: services: nscd: Wait for the PID file. * gnu/services/base.scm (nscd-shepherd-service): Pass #:pid-file. --- gnu/services/base.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 2780d124c7..274ff100e8 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -790,6 +790,11 @@ the tty to run, among other things." "/sbin/nscd") "-f" #$nscd.conf "--foreground") + ;; Wait for the PID file. However, the PID file is + ;; written before nscd is actually listening on its + ;; socket (XXX). + #:pid-file "/var/run/nscd/nscd.pid" + #:environment-variables (list (string-append "LD_LIBRARY_PATH=" (string-join -- cgit v1.2.3 From 9009538d84d20447372c4b9ad608fae0d578815f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 20:59:56 +0200 Subject: services: Export more service types. * gnu/services/base.scm (syslog-service-type): Export. (urandom-seed-service-type): Export. --- gnu/services/base.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gnu/services') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 274ff100e8..f304bf89a3 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -81,6 +81,7 @@ nscd-service-type nscd-service syslog-service + syslog-service-type %default-syslog.conf guix-configuration @@ -94,6 +95,7 @@ gpm-service-type gpm-service + urandom-seed-service-type urandom-seed-service %base-services)) -- cgit v1.2.3 From 194ccecf778faf28be0bce31c629211feb6f1a0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 21:17:05 +0200 Subject: services: avahi: Pass --daemonize and check for the PID file. This makes sure the service's 'start' finishes when avahi-daemon is ready to process requests. * gnu/services/avahi.scm (avahi-shepherd-service): Use --daemonize instead of --syslog and add #:pid-file. --- gnu/services/avahi.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 8005b066ed..7c3bdabff6 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -104,7 +104,8 @@ (start #~(make-forkexec-constructor (list (string-append #$avahi "/sbin/avahi-daemon") - "--syslog" "-f" #$config))) + "--daemonize" "-f" #$config) + #:pid-file "/var/run/avahi-daemon/pid")) (stop #~(make-kill-destructor)))))) (define avahi-service-type -- 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 'gnu/services') 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 @@ 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-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 @@ (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 @@ (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 @@ Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 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 'gnu/services') 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 @@ #: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 @@ urandom-seed-service-type urandom-seed-service + rngd-service-type + rngd-service %base-services)) @@ -486,7 +489,47 @@ stopped before 'kill' is called." (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 6c12abbdb2cdc84f2ca181130dd92907af06971a Mon Sep 17 00:00:00 2001 From: ng0 Date: Thu, 7 Jul 2016 18:57:05 +0000 Subject: services: nginx: Fix typo. * gnu/services/web.scm (nginx-service): Fix typo. Signed-off-by: Leo Famulari --- gnu/services/web.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 0e17f6e5c6..72ef7d4050 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2016 ng0 ;;; ;;; This file is part of GNU Guix. ;;; @@ -114,7 +115,7 @@ (default-nginx-config log-directory run-directory))) "Return a service that runs NGINX, the nginx web server. -The nginx daemon loads its runtime configuration from CONFIG-FIGLE, stores log +The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." (service nginx-service-type (nginx-configuration -- 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 'gnu/services') 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 @@ file." 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 @@ archive}). If that is not the case, the service will fail to start." "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 @@ "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 @@ is set to @var{value} when the bus daemon launches it." (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 @@ Users need to be in the @code{lp} group to access the D-Bus service. (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 @@ keep the system clock synchronized with that of @var{servers}." (($ 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 @@ EndSection "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 @@ under /root/.guix-profile where GUIX is installed." (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 @@ the user's target storage device rather than on the RAM disk." (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 @@ that will be shared with the host system." #: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 @@ (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 @@ loaded at boot time in the order in which they appear." (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 @@ data format changes between libc versions." #: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 @@ `(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 @@ alias ll='ls -l'\n")) (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 @@ set debug-file-directory ~/.guix-profile/lib/debug\n"))) (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 @@ made available under the /xchg CIFS share." (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 @@ 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 @@ functionality tests.") (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 @@ functionality tests.") ".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 @@ TARGET-SIZE bytes containing the installed system." 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 @@ cp /etc/litl-config.scm /mnt/etc/config.scm 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 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 'gnu/services') 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 @@ 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 @@ 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 @@ for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else." (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 @@ stored." (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 @@ (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 (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 @@ (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 2102ae2e30a23b3202f4eeabdc8f37eeb16de691 Mon Sep 17 00:00:00 2001 From: David Craven Date: Wed, 13 Jul 2016 18:13:11 +0200 Subject: gnu: lsh: Move to (gnu packages ssh) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/lsh.scm: Remove. Move 'lsh and liboop' to... * gnu/packages/ssh.scm (liboop, lsh): ... here. New variables. * gnu/services/ssh.scm, gnu/services/base.scm: Adjust accordingly. * gnu/local.mk (GNU_SYSTEM_MODULES): Adjust accordingly. Signed-off-by: Ludovic Courtès --- gnu/local.mk | 1 - gnu/packages/lsh.scm | 159 -------------------------------------------------- gnu/packages/ssh.scm | 158 +++++++++++++++++++++++++++++++++++++++++++++---- gnu/services/base.scm | 2 +- gnu/services/ssh.scm | 2 +- 5 files changed, 148 insertions(+), 174 deletions(-) delete mode 100644 gnu/packages/lsh.scm (limited to 'gnu/services') diff --git a/gnu/local.mk b/gnu/local.mk index d011844074..71409b9735 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -215,7 +215,6 @@ GNU_SYSTEM_MODULES = \ %D%/packages/llvm.scm \ %D%/packages/lout.scm \ %D%/packages/logging.scm \ - %D%/packages/lsh.scm \ %D%/packages/lsof.scm \ %D%/packages/lua.scm \ %D%/packages/lxde.scm \ diff --git a/gnu/packages/lsh.scm b/gnu/packages/lsh.scm deleted file mode 100644 index 2ea1591354..0000000000 --- a/gnu/packages/lsh.scm +++ /dev/null @@ -1,159 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu packages lsh) - #:use-module ((guix licenses) #:prefix license:) - #:use-module (guix packages) - #:use-module (guix download) - #:use-module (guix build-system gnu) - #:use-module (gnu packages) - #:use-module (gnu packages m4) - #:use-module (gnu packages linux) - #:use-module (gnu packages nettle) - #:use-module (gnu packages compression) - #:use-module (gnu packages multiprecision) - #:use-module (gnu packages readline) - #:use-module (gnu packages gperf) - #:use-module (gnu packages guile) - #:use-module (gnu packages xorg)) - -(define-public liboop - (package - (name "liboop") - (version "1.0") - (source - (origin - (method url-fetch) - (uri (string-append "http://download.ofb.net/liboop/liboop-" - version ".tar.gz")) - (sha256 - (base32 - "0z6rlalhvfca64jpvksppc9bdhs7jwhiw4y35g5ibvh91xp3rn1l")) - (patches (search-patches "liboop-mips64-deplibs-fix.patch")))) - (build-system gnu-build-system) - (home-page "http://www.lysator.liu.se/liboop/") - (synopsis "Event loop library") - (description "Liboop is a low-level event loop management library for -POSIX-based operating systems. It supports the development of modular, -multiplexed applications which may respond to events from several sources. It -replaces the \"select() loop\" and allows the registration of event handlers -for file and network I/O, timers and signals. Since processes use these -mechanisms for almost all external communication, liboop can be used as the -basis for almost any application.") - (license license:lgpl2.1+))) - -(define-public lsh - (package - (name "lsh") - (version "2.1") - (source (origin - (method url-fetch) - (uri (string-append "mirror://gnu/lsh/lsh-" - version ".tar.gz")) - (sha256 - (base32 - "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb")) - (modules '((guix build utils))) - (snippet - '(begin - (substitute* "src/testsuite/functions.sh" - (("localhost") - ;; Avoid host name lookups since they don't work in - ;; chroot builds. - "127.0.0.1") - (("set -e") - ;; Make tests more verbose. - "set -e\nset -x")) - - (substitute* (find-files "src/testsuite" "-test$") - (("localhost") "127.0.0.1")) - - (substitute* "src/testsuite/login-auth-test" - (("/bin/cat") "cat")))))) - (build-system gnu-build-system) - (native-inputs - `(("m4" ,m4) - ("guile" ,guile-2.0) - ("gperf" ,gperf) - ("psmisc" ,psmisc))) ; for `killall' - (inputs - `(("nettle" ,nettle-2) - ("linux-pam" ,linux-pam) - - ;; 'rl.c' uses the 'CPPFunction' type, which is no longer in - ;; Readline 6.3. - ("readline" ,readline-6.2) - - ("liboop" ,liboop) - ("zlib" ,zlib) - ("gmp" ,gmp) - - ;; The server (lshd) invokes xauth when X11 forwarding is requested. - ;; This adds 24 MiB (or 27%) to the closure of lsh. - ("xauth" ,xauth))) - (arguments - '(;; Skip the `configure' test that checks whether /dev/ptmx & - ;; co. work as expected, because it relies on impurities (for - ;; instance, /dev/pts may be unavailable in chroots.) - #:configure-flags '("lsh_cv_sys_unix98_ptys=yes") - - ;; FIXME: Tests won't run in a chroot, presumably because - ;; /etc/profile is missing, and thus clients get an empty $PATH - ;; and nothing works. - #:tests? #f - - #:phases - (modify-phases %standard-phases - (add-before 'configure 'pre-configure - (lambda* (#:key inputs #:allow-other-keys) - (let* ((nettle (assoc-ref inputs "nettle")) - (sexp-conv (string-append nettle "/bin/sexp-conv"))) - ;; Make sure 'lsh' and 'lshd' pick 'sexp-conv' in the right place - ;; by default. - (substitute* "src/environ.h.in" - (("^#define PATH_SEXP_CONV.*") - (string-append "#define PATH_SEXP_CONV \"" - sexp-conv "\"\n"))) - - ;; Same for the 'lsh-authorize' script. - (substitute* "src/lsh-authorize" - (("=sexp-conv") - (string-append "=" sexp-conv))) - - ;; Tell lshd where 'xauth' lives. Another option would be to - ;; hardcode "/run/current-system/profile/bin/xauth", thereby - ;; reducing the closure size, but that wouldn't work on foreign - ;; distros. - (with-fluids ((%default-port-encoding "ISO-8859-1")) - (substitute* "src/server_x11.c" - (("define XAUTH_PROGRAM.*") - (string-append "define XAUTH_PROGRAM \"" - (assoc-ref inputs "xauth") - "/bin/xauth\"\n"))))) - - ;; Tests rely on $USER being set. - (setenv "USER" "guix")))))) - (home-page "http://www.lysator.liu.se/~nisse/lsh/") - (synopsis "GNU implementation of the Secure Shell (ssh) protocols") - (description - "GNU lsh is a free implementation of the SSH version 2 protocol. It is -used to create a secure line of communication between two computers, -providing shell access to the server system from the client. It provides -both the server daemon and the client application, as well as tools for -manipulating key files.") - (license license:gpl2+))) diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index c782d4d869..71310ecf94 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -1,4 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2014, 2015, 2016 Mark H Weaver ;;; Copyright © 2015, 2016 Efraim Flashner @@ -20,27 +21,34 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages ssh) - #:use-module ((guix licenses) #:prefix license:) + #:use-module (gnu packages) + #:use-module (gnu packages autotools) + #:use-module (gnu packages base) + #:autoload (gnu packages boost) (boost) #:use-module (gnu packages compression) + #:use-module (gnu packages elf) #:use-module (gnu packages gnupg) + #:use-module (gnu packages gperf) #:use-module (gnu packages groff) - #:use-module (gnu packages elf) #:use-module (gnu packages guile) - #:use-module (gnu packages pkg-config) - #:use-module (gnu packages autotools) - #:use-module (gnu packages texinfo) - #:use-module (gnu packages perl) + #:use-module (gnu packages linux) + #:use-module (gnu packages m4) + #:use-module (gnu packages multiprecision) #:use-module (gnu packages ncurses) + #:use-module (gnu packages nettle) + #:use-module (gnu packages perl) + #:use-module (gnu packages pkg-config) #:autoload (gnu packages protobuf) (protobuf) - #:autoload (gnu packages boost) (boost) - #:use-module (gnu packages base) + #:use-module (gnu packages readline) + #:use-module (gnu packages texinfo) #:use-module (gnu packages tls) - #:use-module (gnu packages) - #:use-module (guix packages) + #:use-module (gnu packages xorg) + #:use-module (guix build-system cmake) + #:use-module (guix build-system gnu) #:use-module (guix download) #:use-module (guix git-download) - #:use-module (guix build-system gnu) - #:use-module (guix build-system cmake)) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix packages)) (define-public libssh (package @@ -355,3 +363,129 @@ client. It runs on a variety of POSIX-based platforms. Dropbear is particularly useful for embedded systems, such as wireless routers.") (home-page "https://matt.ucc.asn.au/dropbear/dropbear.html") (license (license:x11-style "" "See file LICENSE.")))) + +(define-public liboop + (package + (name "liboop") + (version "1.0") + (source + (origin + (method url-fetch) + (uri (string-append "http://download.ofb.net/liboop/liboop-" + version ".tar.gz")) + (sha256 + (base32 + "0z6rlalhvfca64jpvksppc9bdhs7jwhiw4y35g5ibvh91xp3rn1l")) + (patches (search-patches "liboop-mips64-deplibs-fix.patch")))) + (build-system gnu-build-system) + (home-page "http://www.lysator.liu.se/liboop/") + (synopsis "Event loop library") + (description "Liboop is a low-level event loop management library for +POSIX-based operating systems. It supports the development of modular, +multiplexed applications which may respond to events from several sources. It +replaces the \"select() loop\" and allows the registration of event handlers +for file and network I/O, timers and signals. Since processes use these +mechanisms for almost all external communication, liboop can be used as the +basis for almost any application.") + (license license:lgpl2.1+))) + +(define-public lsh + (package + (name "lsh") + (version "2.1") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/lsh/lsh-" + version ".tar.gz")) + (sha256 + (base32 + "1qqjy9zfzgny0rkb27c8c7dfsylvb6n0ld8h3an2r83pmaqr9gwb")) + (modules '((guix build utils))) + (snippet + '(begin + (substitute* "src/testsuite/functions.sh" + (("localhost") + ;; Avoid host name lookups since they don't work in + ;; chroot builds. + "127.0.0.1") + (("set -e") + ;; Make tests more verbose. + "set -e\nset -x")) + + (substitute* (find-files "src/testsuite" "-test$") + (("localhost") "127.0.0.1")) + + (substitute* "src/testsuite/login-auth-test" + (("/bin/cat") "cat")))))) + (build-system gnu-build-system) + (native-inputs + `(("m4" ,m4) + ("guile" ,guile-2.0) + ("gperf" ,gperf) + ("psmisc" ,psmisc))) ; for `killall' + (inputs + `(("nettle" ,nettle-2) + ("linux-pam" ,linux-pam) + + ;; 'rl.c' uses the 'CPPFunction' type, which is no longer in + ;; Readline 6.3. + ("readline" ,readline-6.2) + + ("liboop" ,liboop) + ("zlib" ,zlib) + ("gmp" ,gmp) + + ;; The server (lshd) invokes xauth when X11 forwarding is requested. + ;; This adds 24 MiB (or 27%) to the closure of lsh. + ("xauth" ,xauth))) + (arguments + '(;; Skip the `configure' test that checks whether /dev/ptmx & + ;; co. work as expected, because it relies on impurities (for + ;; instance, /dev/pts may be unavailable in chroots.) + #:configure-flags '("lsh_cv_sys_unix98_ptys=yes") + + ;; FIXME: Tests won't run in a chroot, presumably because + ;; /etc/profile is missing, and thus clients get an empty $PATH + ;; and nothing works. + #:tests? #f + + #:phases + (modify-phases %standard-phases + (add-before 'configure 'pre-configure + (lambda* (#:key inputs #:allow-other-keys) + (let* ((nettle (assoc-ref inputs "nettle")) + (sexp-conv (string-append nettle "/bin/sexp-conv"))) + ;; Make sure 'lsh' and 'lshd' pick 'sexp-conv' in the right place + ;; by default. + (substitute* "src/environ.h.in" + (("^#define PATH_SEXP_CONV.*") + (string-append "#define PATH_SEXP_CONV \"" + sexp-conv "\"\n"))) + + ;; Same for the 'lsh-authorize' script. + (substitute* "src/lsh-authorize" + (("=sexp-conv") + (string-append "=" sexp-conv))) + + ;; Tell lshd where 'xauth' lives. Another option would be to + ;; hardcode "/run/current-system/profile/bin/xauth", thereby + ;; reducing the closure size, but that wouldn't work on foreign + ;; distros. + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (substitute* "src/server_x11.c" + (("define XAUTH_PROGRAM.*") + (string-append "define XAUTH_PROGRAM \"" + (assoc-ref inputs "xauth") + "/bin/xauth\"\n"))))) + + ;; Tests rely on $USER being set. + (setenv "USER" "guix")))))) + (home-page "http://www.lysator.liu.se/~nisse/lsh/") + (synopsis "GNU implementation of the Secure Shell (ssh) protocols") + (description + "GNU lsh is a free implementation of the SSH version 2 protocol. It is +used to create a secure line of communication between two computers, +providing shell access to the server system from the client. It provides +both the server daemon and the client application, as well as tools for +manipulating key files.") + (license license:gpl2+))) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 02e3b41904..c9c2594533 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -36,7 +36,7 @@ #:use-module ((gnu packages base) #:select (canonical-package glibc)) #:use-module (gnu packages package-management) - #:use-module (gnu packages lsh) + #:use-module (gnu packages ssh) #:use-module (gnu packages lsof) #:use-module ((gnu build file-systems) #:select (mount-flags->bit-mask)) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 33e1951a6e..1eb9382a84 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -22,7 +22,7 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system pam) - #:use-module (gnu packages lsh) + #:use-module (gnu packages ssh) #:use-module (srfi srfi-26) #:export (lsh-service)) -- 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 'gnu/services') 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 @@ The other options should be self-descriptive." 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 b9bb50c608447170891af524a614748210deea89 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 16 Jul 2016 00:03:41 +0200 Subject: services: dbus: Synchronize startup using dbus-daemon's PID file. * gnu/services/dbus.scm (dbus-shepherd-service): Pass #:pid-file to 'make-forkexec-constructor'. --- gnu/services/dbus.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index d06b2dde23..6ef13568ef 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -169,7 +169,8 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (requirement '(user-processes)) (start #~(make-forkexec-constructor (list (string-append #$dbus "/bin/dbus-daemon") - "--nofork" "--system"))) + "--nofork" "--system") + #:pid-file "/var/run/dbus/pid")) (stop #~(make-kill-destructor))))))) (define dbus-root-service-type -- cgit v1.2.3 From 2c2ec261a8d3c37e5147038f47ad24c57cde4134 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 15:22:37 +0200 Subject: services: shepherd: Clarify error message about missing service. Suggested by Tobias Geerinckx-Rice . * gnu/services/shepherd.scm (assert-valid-graph)[assert-satisfied-requirements]: Clarify error message. --- gnu/services/shepherd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/services') diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index f35a6bf10a..a14f51592a 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -175,7 +175,7 @@ assertion failure." (&message (message (format #f (_ "service '~a' requires '~a', \ -which is undefined") +which is not provided by any service") (match (shepherd-service-provision service) ((head . _) head) (_ service)) -- 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 'gnu/services') 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 @@ urandom-seed-service rngd-service-type rngd-service + pam-limits-service-type + pam-limits-service %base-services)) @@ -924,6 +927,46 @@ settings. 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 @@ #: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 @@ 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 @@ (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