summaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm264
1 files changed, 178 insertions, 86 deletions
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
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-28 00:58:11 +0000