aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/avahi.scm12
-rw-r--r--gnu/services/base.scm264
-rw-r--r--gnu/services/dbus.scm44
-rw-r--r--gnu/services/desktop.scm67
-rw-r--r--gnu/services/networking.scm54
-rw-r--r--gnu/services/shepherd.scm45
-rw-r--r--gnu/services/ssh.scm97
-rw-r--r--gnu/services/web.scm3
-rw-r--r--gnu/services/xorg.scm42
9 files changed, 402 insertions, 226 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm
index 8005b066ed..562005c22c 100644
--- a/gnu/services/avahi.scm
+++ b/gnu/services/avahi.scm
@@ -42,6 +42,8 @@
avahi-configuration?
(avahi avahi-configuration-avahi ;<package>
(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 <shepherd-service> 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,10 @@
(start #~(make-forkexec-constructor
(list (string-append #$avahi "/sbin/avahi-daemon")
- "--syslog" "-f" #$config)))
+ "--daemonize"
+ #$@(if debug? #~("--debug") #~())
+ "-f" #$config)
+ #:pid-file "/var/run/avahi-daemon/pid"))
(stop #~(make-kill-destructor))))))
(define avahi-service-type
@@ -127,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)
@@ -155,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))))
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 2780d124c7..805ba7d12c 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -4,6 +4,8 @@
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,11 +33,11 @@
#: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)
- #: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))
@@ -81,6 +83,7 @@
nscd-service-type
nscd-service
syslog-service
+ syslog-service-type
%default-syslog.conf
guix-configuration
@@ -94,7 +97,12 @@
gpm-service-type
gpm-service
+ urandom-seed-service-type
urandom-seed-service
+ rngd-service-type
+ rngd-service
+ pam-limits-service-type
+ pam-limits-service
%base-services))
@@ -224,59 +232,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 <http://lwn.net/Articles/281157/>,
- ;; 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 <http://lwn.net/Articles/281157/>,
+ ;; 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
@@ -484,7 +491,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>
+ 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.
;;;
@@ -790,6 +837,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
@@ -875,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.
@@ -1088,44 +1180,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..6ef13568ef 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
@@ -168,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
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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;;
@@ -345,39 +345,39 @@ keep the system clock synchronized with that of @var{servers}."
(($ <tor-configuration> 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
- (($ <hidden-service> 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
+ (($ <hidden-service> 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 <shepherd-service> running TOR."
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 5d829e4c38..a14f51592a 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."
@@ -179,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))
@@ -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 <service>
- #: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 <service>
+ #: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/services/ssh.scm b/gnu/services/ssh.scm
index 33e1951a6e..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 <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 David Craven <david@craven.ch>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,14 +18,19 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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 lsh)
+ #: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>
+ 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 <shepherd-service> 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{<dropbear-configuration>}
+object."
+ (service dropbear-service-type config))
+
;;; ssh.scm ends here
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 <davet@gnu.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is>
;;;
;;; 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
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))