aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm1009
1 files changed, 595 insertions, 414 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d9d73b4597..adafe1b55e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -21,9 +21,11 @@
(define-module (gnu services base)
#:use-module (guix store)
#:use-module (gnu services)
+ #:use-module (gnu services dmd)
#:use-module (gnu services networking)
#:use-module (gnu system shadow) ; 'user-account', etc.
#:use-module (gnu system linux) ; 'pam-service', etc.
+ #:use-module (gnu system file-systems) ; 'file-system', etc.
#:use-module (gnu packages admin)
#:use-module ((gnu packages linux)
#:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda))
@@ -49,6 +51,7 @@
host-name-service
console-keymap-service
console-font-service
+ udev-service-type
udev-service
mingetty-configuration
@@ -64,9 +67,14 @@
nscd-cache
nscd-cache?
+ nscd-service-type
nscd-service
syslog-service
+
+ guix-configuration
+ guix-configuration?
guix-service
+
%base-services))
;;; Commentary:
@@ -76,13 +84,13 @@
;;;
;;; Code:
-(define (root-file-system-service)
- "Return a service whose sole purpose is to re-mount read-only the root file
-system upon shutdown (aka. cleanly \"umounting\" root.)
+
+;;;
+;;; File systems.
+;;;
-This service must be the root of the service dependency graph so that its
-'stop' action is invoked when dmd is the only process left."
- (service
+(define %root-file-system-dmd-service
+ (dmd-service
(documentation "Take care of the root file system.")
(provision '(root-file-system))
(start #~(const #t))
@@ -116,181 +124,230 @@ This service must be the root of the service dependency graph so that its
#f)))))
(respawn? #f)))
-(define* (file-system-service device target type
- #:key (flags '()) (check? #t)
- create-mount-point? options (title 'any)
- (requirements '()))
- "Return a service that mounts DEVICE on TARGET as a file system TYPE with
-OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for
-a partition label, 'device for a device file name, or 'any. When CHECK? is
-true, check the file system before mounting it. When CREATE-MOUNT-POINT? is
-true, create TARGET if it does not exist yet. FLAGS is a list of symbols,
-such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service
-names such as device-mapping services."
- (service
- (provision (list (symbol-append 'file-system- (string->symbol target))))
- (requirement `(root-file-system ,@requirements))
- (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 flags)))
- #$(if create-mount-point?
- #~(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 #$options)
-
- ;; 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))))
+(define root-file-system-service-type
+ (dmd-service-type (const %root-file-system-dmd-service)))
+
+(define (root-file-system-service)
+ "Return a service whose sole purpose is to re-mount read-only the root file
+system upon shutdown (aka. cleanly \"umounting\" root.)
+
+This service must be the root of the service dependency graph so that its
+'stop' action is invoked when dmd is the only process left."
+ (service root-file-system-service-type #f))
+
+(define (file-system->dmd-service-name file-system)
+ "Return the symbol that denotes the service mounting and unmounting
+FILE-SYSTEM."
+ (symbol-append 'file-system-
+ (string->symbol (file-system-mount-point file-system))))
+
+(define file-system-service-type
+ ;; TODO(?): Make this an extensible service that takes <file-system> objects
+ ;; and returns a list of <dmd-service>.
+ (dmd-service-type
+ (lambda (file-system)
+ (let ((target (file-system-mount-point file-system))
+ (device (file-system-device file-system))
+ (type (file-system-type file-system))
+ (title (file-system-title file-system))
+ (check? (file-system-check? file-system))
+ (create? (file-system-create-mount-point? file-system))
+ (dependencies (file-system-dependencies file-system)))
+ (dmd-service
+ (provision (list (file-system->dmd-service-name file-system)))
+ (requirement `(root-file-system
+ ,@(map file-system->dmd-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)))))))
+
+(define* (file-system-service file-system)
+ "Return a service that mounts @var{file-system}, a @code{<file-system>}
+object."
+ (service file-system-service-type file-system))
+
+(define user-unmount-service-type
+ (dmd-service-type
+ (lambda (known-mount-points)
+ (dmd-service
+ (documentation "Unmount manually-mounted file systems.")
+ (provision '(user-unmount))
+ (start #~(const #t))
+ (stop #~(lambda args
+ (define (known? mount-point)
+ (member mount-point
+ (cons* "/proc" "/sys" '#$known-mount-points)))
+
+ ;; Make sure we don't keep the user's mount points busy.
+ (chdir "/")
+
+ (for-each (lambda (mount-point)
+ (format #t "unmounting '~a'...~%" mount-point)
+ (catch 'system-error
+ (lambda ()
+ (umount mount-point))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format #t "failed to unmount '~a': ~a~%"
+ mount-point (strerror errno))))))
+ (filter (negate known?) (mount-points)))
+ #f))))))
(define (user-unmount-service known-mount-points)
"Return a service whose sole purpose is to unmount file systems not listed
in KNOWN-MOUNT-POINTS when it is stopped."
- (service
- (documentation "Unmount manually-mounted file systems.")
- (provision '(user-unmount))
- (start #~(const #t))
- (stop #~(lambda args
- (define (known? mount-point)
- (member mount-point
- (cons* "/proc" "/sys"
- '#$known-mount-points)))
-
- ;; Make sure we don't keep the user's mount points busy.
- (chdir "/")
-
- (for-each (lambda (mount-point)
- (format #t "unmounting '~a'...~%" mount-point)
- (catch 'system-error
- (lambda ()
- (umount mount-point))
- (lambda args
- (let ((errno (system-error-errno args)))
- (format #t "failed to unmount '~a': ~a~%"
- mount-point (strerror errno))))))
- (filter (negate known?) (mount-points)))
- #f))))
+ (service user-unmount-service-type known-mount-points))
(define %do-not-kill-file
;; Name of the file listing PIDs of processes that must survive when halting
;; the system. Typical example is user-space file systems.
"/etc/dmd/do-not-kill")
-(define* (user-processes-service requirements #:key (grace-delay 4))
+(define user-processes-service-type
+ (dmd-service-type
+ (match-lambda
+ ((requirements grace-delay)
+ (dmd-service
+ (documentation "When stopped, terminate all user processes.")
+ (provision '(user-processes))
+ (requirement (cons 'root-file-system
+ (map file-system->dmd-service-name
+ requirements)))
+ (start #~(const #t))
+ (stop #~(lambda _
+ (define (kill-except omit signal)
+ ;; Kill all the processes with SIGNAL except those listed
+ ;; in OMIT and the current process.
+ (let ((omit (cons (getpid) omit)))
+ (for-each (lambda (pid)
+ (unless (memv pid omit)
+ (false-if-exception
+ (kill pid signal))))
+ (processes))))
+
+ (define omitted-pids
+ ;; List of PIDs that must not be killed.
+ (if (file-exists? #$%do-not-kill-file)
+ (map string->number
+ (call-with-input-file #$%do-not-kill-file
+ (compose string-tokenize
+ (@ (ice-9 rdelim) read-string))))
+ '()))
+
+ (define (now)
+ (car (gettimeofday)))
+
+ (define (sleep* n)
+ ;; Really sleep N seconds.
+ ;; Work around <http://bugs.gnu.org/19581>.
+ (define start (now))
+ (let loop ((elapsed 0))
+ (when (> n elapsed)
+ (sleep (- n elapsed))
+ (loop (- (now) start)))))
+
+ (define lset= (@ (srfi srfi-1) lset=))
+
+ (display "sending all processes the TERM signal\n")
+
+ (if (null? omitted-pids)
+ (begin
+ ;; Easy: terminate all of them.
+ (kill -1 SIGTERM)
+ (sleep* #$grace-delay)
+ (kill -1 SIGKILL))
+ (begin
+ ;; Kill them all except OMITTED-PIDS. XXX: We would
+ ;; like to (kill -1 SIGSTOP) to get a fixed list of
+ ;; processes, like 'killall5' does, but that seems
+ ;; unreliable.
+ (kill-except omitted-pids SIGTERM)
+ (sleep* #$grace-delay)
+ (kill-except omitted-pids SIGKILL)
+ (delete-file #$%do-not-kill-file)))
+
+ (let wait ()
+ (let ((pids (processes)))
+ (unless (lset= = pids (cons 1 omitted-pids))
+ (format #t "waiting for process termination\
+ (processes left: ~s)~%"
+ pids)
+ (sleep* 2)
+ (wait))))
+
+ (display "all processes have been terminated\n")
+ #f))
+ (respawn? #f))))))
+
+(define* (user-processes-service file-systems #:key (grace-delay 4))
"Return the service that is responsible for terminating all the processes so
that the root file system can be re-mounted read-only, just before
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
has been sent are terminated with SIGKILL.
-The returned service will depend on 'root-file-system' and on all the services
-listed in REQUIREMENTS.
+The returned service will depend on 'root-file-system' and on all the dmd
+services corresponding to FILE-SYSTEMS.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
- (service
- (documentation "When stopped, terminate all user processes.")
- (provision '(user-processes))
- (requirement (cons 'root-file-system requirements))
- (start #~(const #t))
- (stop #~(lambda _
- (define (kill-except omit signal)
- ;; Kill all the processes with SIGNAL except those
- ;; listed in OMIT and the current process.
- (let ((omit (cons (getpid) omit)))
- (for-each (lambda (pid)
- (unless (memv pid omit)
- (false-if-exception
- (kill pid signal))))
- (processes))))
-
- (define omitted-pids
- ;; List of PIDs that must not be killed.
- (if (file-exists? #$%do-not-kill-file)
- (map string->number
- (call-with-input-file #$%do-not-kill-file
- (compose string-tokenize
- (@ (ice-9 rdelim) read-string))))
- '()))
-
- (define (now)
- (car (gettimeofday)))
-
- (define (sleep* n)
- ;; Really sleep N seconds.
- ;; Work around <http://bugs.gnu.org/19581>.
- (define start (now))
- (let loop ((elapsed 0))
- (when (> n elapsed)
- (sleep (- n elapsed))
- (loop (- (now) start)))))
-
- (define lset= (@ (srfi srfi-1) lset=))
-
- (display "sending all processes the TERM signal\n")
-
- (if (null? omitted-pids)
- (begin
- ;; Easy: terminate all of them.
- (kill -1 SIGTERM)
- (sleep* #$grace-delay)
- (kill -1 SIGKILL))
- (begin
- ;; Kill them all except OMITTED-PIDS. XXX: We
- ;; would like to (kill -1 SIGSTOP) to get a fixed
- ;; list of processes, like 'killall5' does, but
- ;; that seems unreliable.
- (kill-except omitted-pids SIGTERM)
- (sleep* #$grace-delay)
- (kill-except omitted-pids SIGKILL)
- (delete-file #$%do-not-kill-file)))
-
- (let wait ()
- (let ((pids (processes)))
- (unless (lset= = pids (cons 1 omitted-pids))
- (format #t "waiting for process termination\
- (processes left: ~s)~%"
- pids)
- (sleep* 2)
- (wait))))
+ (service user-processes-service-type
+ (list file-systems grace-delay)))
- (display "all processes have been terminated\n")
- #f))
- (respawn? #f)))
+
+;;;
+;;; Console & co.
+;;;
+
+(define host-name-service-type
+ (dmd-service-type
+ (lambda (name)
+ (dmd-service
+ (documentation "Initialize the machine's host name.")
+ (provision '(host-name))
+ (start #~(lambda _
+ (sethostname #$name)))
+ (respawn? #f)))))
(define (host-name-service name)
"Return a service that sets the host name to @var{name}."
- (service
- (documentation "Initialize the machine's host name.")
- (provision '(host-name))
- (start #~(lambda _
- (sethostname #$name)))
- (respawn? #f)))
+ (service host-name-service-type name))
(define (unicode-start tty)
"Return a gexp to start Unicode support on @var{tty}."
@@ -310,15 +367,43 @@ stopped before 'kill' is called."
(else
(zero? (cdr (waitpid pid))))))))
+(define console-keymap-service-type
+ (dmd-service-type
+ (lambda (file)
+ (dmd-service
+ (documentation (string-append "Load console keymap (loadkeys)."))
+ (provision '(console-keymap))
+ (start #~(lambda _
+ (zero? (system* (string-append #$kbd "/bin/loadkeys")
+ #$file))))
+ (respawn? #f)))))
+
(define (console-keymap-service file)
"Return a service to load console keymap from @var{file}."
- (service
- (documentation (string-append "Load console keymap (loadkeys)."))
- (provision '(console-keymap))
- (start #~(lambda _
- (zero? (system* (string-append #$kbd "/bin/loadkeys")
- #$file))))
- (respawn? #f)))
+ (service console-keymap-service-type file))
+
+(define console-font-service-type
+ (dmd-service-type
+ (match-lambda
+ ((tty font)
+ (let ((device (string-append "/dev/" tty)))
+ (dmd-service
+ (documentation "Load a Unicode console font.")
+ (provision (list (symbol-append 'console-font-
+ (string->symbol tty))))
+
+ ;; Start after mingetty has been started on TTY, otherwise the settings
+ ;; are ignored.
+ (requirement (list (symbol-append 'term-
+ (string->symbol tty))))
+
+ (start #~(lambda _
+ (and #$(unicode-start device)
+ (zero?
+ (system* (string-append #$kbd "/bin/setfont")
+ "-C" #$device #$font)))))
+ (stop #~(const #t))
+ (respawn? #f)))))))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
"Return a service that sets up Unicode support in @var{tty} and loads
@@ -326,24 +411,7 @@ stopped before 'kill' is called."
;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
;; codepoints notably found in the UTF-8 manual.
- (let ((device (string-append "/dev/" tty)))
- (service
- (documentation "Load a Unicode console font.")
- (provision (list (symbol-append 'console-font-
- (string->symbol tty))))
-
- ;; Start after mingetty has been started on TTY, otherwise the
- ;; settings are ignored.
- (requirement (list (symbol-append 'term-
- (string->symbol tty))))
-
- (start #~(lambda _
- (and #$(unicode-start device)
- (zero?
- (system* (string-append #$kbd "/bin/setfont")
- "-C" #$device #$font)))))
- (stop #~(const #t))
- (respawn? #f))))
+ (service console-font-service-type (list tty font)))
(define-record-type* <mingetty-configuration>
mingetty-configuration make-mingetty-configuration
@@ -365,43 +433,56 @@ stopped before 'kill' is called."
(allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
(default #t))) ;Boolean
-(define* (mingetty-service config)
- "Return a service to run mingetty according to @var{config}, a
-@code{<mingetty-configuration>} object, which specifies the tty to run, among
-other things."
- (match config
+(define (mingetty-pam-service conf)
+ "Return the list of PAM service needed for CONF."
+ ;; Let 'login' be known to PAM. All the mingetty services will have that
+ ;; PAM service, but that's fine because they're all identical and duplicates
+ ;; are removed.
+ (list (unix-pam-service "login"
+ #:allow-empty-passwords?
+ (mingetty-configuration-allow-empty-passwords? conf)
+ #:motd
+ (mingetty-configuration-motd conf))))
+
+(define mingetty-dmd-service
+ (match-lambda
(($ <mingetty-configuration> mingetty tty motd auto-login login-program
login-pause? allow-empty-passwords?)
- (service
- (documentation "Run mingetty on an tty.")
- (provision (list (symbol-append 'term- (string->symbol tty))))
-
- ;; Since the login prompt shows the host name, wait for the 'host-name'
- ;; service to be done. Also wait for udev essentially so that the tty
- ;; text is not lost in the middle of kernel messages (XXX).
- (requirement '(user-processes host-name udev))
-
- (start #~(make-forkexec-constructor
- (list (string-append #$mingetty "/sbin/mingetty")
- "--noclear" #$tty
- #$@(if auto-login
- #~("--autologin" #$auto-login)
- #~())
- #$@(if login-program
- #~("--loginprog" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--loginpause")
- #~()))))
- (stop #~(make-kill-destructor))
-
- (pam-services
- ;; Let 'login' be known to PAM. All the mingetty services will have
- ;; that PAM service, but that's fine because they're all identical and
- ;; duplicates are removed.
- (list (unix-pam-service "login"
- #:allow-empty-passwords? allow-empty-passwords?
- #:motd motd)))))))
+ (list
+ (dmd-service
+ (documentation "Run mingetty on an tty.")
+ (provision (list (symbol-append 'term- (string->symbol tty))))
+
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done. Also wait for udev essentially so that the tty
+ ;; text is not lost in the middle of kernel messages (XXX).
+ (requirement '(user-processes host-name udev))
+
+ (start #~(make-forkexec-constructor
+ (list (string-append #$mingetty "/sbin/mingetty")
+ "--noclear" #$tty
+ #$@(if auto-login
+ #~("--autologin" #$auto-login)
+ #~())
+ #$@(if login-program
+ #~("--loginprog" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--loginpause")
+ #~()))))
+ (stop #~(make-kill-destructor)))))))
+
+(define mingetty-service-type
+ (service-type (name 'mingetty)
+ (extensions (list (service-extension dmd-root-service-type
+ mingetty-dmd-service)
+ (service-extension pam-root-service-type
+ mingetty-pam-service)))))
+
+(define* (mingetty-service config)
+ "Return a service to run mingetty according to @var{config}, which specifies
+the tty to run, among other things."
+ (service mingetty-service-type config))
(define-record-type* <nscd-configuration> nscd-configuration
make-nscd-configuration
@@ -506,38 +587,72 @@ other things."
(string-concatenate
(map cache->config caches)))))))
+(define (nscd-dmd-service config)
+ "Return a dmd service for CONFIG, an <nscd-configuration> object."
+ (let ((nscd.conf (nscd.conf-file config))
+ (name-services (nscd-configuration-name-services config)))
+ (list (dmd-service
+ (documentation "Run libc's name service cache daemon (nscd).")
+ (provision '(nscd))
+ (requirement '(user-processes))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$(nscd-configuration-glibc config)
+ "/sbin/nscd")
+ "-f" #$nscd.conf "--foreground")
+
+ #:environment-variables
+ (list (string-append "LD_LIBRARY_PATH="
+ (string-join
+ (map (lambda (dir)
+ (string-append dir "/lib"))
+ (list #$@name-services))
+ ":")))))
+ (stop #~(make-kill-destructor))
+
+ (respawn? #f)))))
+
+(define nscd-activation
+ ;; Actions to take before starting nscd.
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/run/nscd")
+ (mkdir-p "/var/db/nscd"))) ;for the persistent cache
+
+(define nscd-service-type
+ (service-type (name 'nscd)
+ (extensions
+ (list (service-extension activation-service-type
+ (const nscd-activation))
+ (service-extension dmd-root-service-type
+ nscd-dmd-service)))
+
+ ;; This can be extended by providing additional name services
+ ;; such as nss-mdns.
+ (compose concatenate)
+ (extend (lambda (config name-services)
+ (nscd-configuration
+ (inherit config)
+ (name-services (append
+ (nscd-configuration-name-services config)
+ name-services)))))))
+
(define* (nscd-service #:optional (config %nscd-default-configuration))
"Return a service that runs libc's name service cache daemon (nscd) with the
given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
Service Switch}, for an example."
- (let ((nscd.conf (nscd.conf-file config)))
- (service
- (documentation "Run libc's name service cache daemon (nscd).")
- (provision '(nscd))
- (requirement '(user-processes))
-
- (activate #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/run/nscd")
- (mkdir-p "/var/db/nscd"))) ;for the persistent cache
-
- (start #~(make-forkexec-constructor
- (list (string-append #$(nscd-configuration-glibc config)
- "/sbin/nscd")
- "-f" #$nscd.conf "--foreground")
-
- #:environment-variables
- (list (string-append "LD_LIBRARY_PATH="
- (string-join
- (map (lambda (dir)
- (string-append dir "/lib"))
- (list
- #$@(nscd-configuration-name-services
- config)))
- ":")))))
- (stop #~(make-kill-destructor))
-
- (respawn? #f))))
+ (service nscd-service-type config))
+
+(define syslog-service-type
+ (dmd-service-type
+ (lambda (config-file)
+ (dmd-service
+ (documentation "Run the syslog daemon (syslogd).")
+ (provision '(syslogd))
+ (requirement '(user-processes))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$inetutils "/libexec/syslogd")
+ "--no-detach" "--rcfile" #$config-file)))
+ (stop #~(make-kill-destructor))))))
;; Snippet adapted from the GNU inetutils manual.
(define %default-syslog.conf
@@ -561,18 +676,12 @@ Service Switch}, for an example."
# Log all the mail messages in one place.
mail.* /var/log/maillog
"))
+
(define* (syslog-service #:key (config-file %default-syslog.conf))
"Return a service that runs @code{syslogd}.
If configuration file name @var{config-file} is not specified, use some
reasonable default settings."
- (service
- (documentation "Run the syslog daemon (syslogd).")
- (provision '(syslogd))
- (requirement '(user-processes))
- (start #~(make-forkexec-constructor
- (list (string-append #$inetutils "/libexec/syslogd")
- "--no-detach" "--rcfile" #$config-file)))
- (stop #~(make-kill-destructor))))
+ (service syslog-service-type config-file))
(define* (guix-build-accounts count #:key
(group "guixbuild")
@@ -621,61 +730,104 @@ GUIX."
(format (current-error-port) "warning: \
failed to register hydra.gnu.org public key: ~a~%" status))))))))
-(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
- (build-accounts 10) (authorize-hydra-key? #t)
- (use-substitutes? #t)
- (extra-options '())
- (lsof lsof) (lsh lsh))
- "Return a service that runs the build daemon from @var{guix}, and has
-@var{build-accounts} user accounts available under @var{builder-group}.
-
-When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key
-provided by @var{guix} is authorized upon activation, meaning that substitutes
-from @code{hydra.gnu.org} are used by default.
-
-If @var{use-substitutes?} is false, the daemon is run with
-@option{--no-substitutes} (@pxref{Invoking guix-daemon,
-@option{--no-substitutes}}).
-
-Finally, @var{extra-options} is a list of additional command-line options
-passed to @command{guix-daemon}."
- (define activate
- ;; Assume that the store has BUILDER-GROUP as its group. We could
- ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
- ;; chown leads to an entire copy of the tree, which is a bad idea.
-
- ;; Optionally authorize hydra.gnu.org's key.
- (and authorize-hydra-key?
- (hydra-key-authorization guix)))
-
- (service
- (documentation "Run the Guix daemon.")
- (provision '(guix-daemon))
- (requirement '(user-processes))
- (start
- #~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix-daemon")
- "--build-users-group" #$builder-group
- #$@(if use-substitutes?
- '()
- '("--no-substitutes"))
- #$@extra-options)
-
- ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
- ;; daemon's $PATH.
- #:environment-variables
- (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
- (stop #~(make-kill-destructor))
- (user-accounts (guix-build-accounts build-accounts
- #:group builder-group))
- (user-groups (list (user-group
- (name builder-group)
- (system? #t)
-
- ;; Use a fixed GID so that we can create the
- ;; store with the right owner.
- (id 30000))))
- (activate activate)))
+(define-record-type* <guix-configuration>
+ guix-configuration make-guix-configuration
+ guix-configuration?
+ (guix guix-configuration-guix ;<package>
+ (default guix))
+ (build-group guix-configuration-build-group ;string
+ (default "guixbuild"))
+ (build-accounts guix-configuration-build-accounts ;integer
+ (default 10))
+ (authorize-key? guix-configuration-authorize-key? ;Boolean
+ (default #t))
+ (use-substitutes? guix-configuration-use-substitutes? ;Boolean
+ (default #t))
+ (extra-options guix-configuration-extra-options ;list of strings
+ (default '()))
+ (lsof guix-configuration-lsof ;<package>
+ (default lsof))
+ (lsh guix-configuration-lsh ;<package>
+ (default lsh)))
+
+(define %default-guix-configuration
+ (guix-configuration))
+
+(define (guix-dmd-service config)
+ "Return a <dmd-service> for the Guix daemon service with CONFIG."
+ (match config
+ (($ <guix-configuration> guix build-group build-accounts authorize-key?
+ use-substitutes? extra-options lsof lsh)
+ (list (dmd-service
+ (documentation "Run the Guix daemon.")
+ (provision '(guix-daemon))
+ (requirement '(user-processes))
+ (start
+ #~(make-forkexec-constructor
+ (list (string-append #$guix "/bin/guix-daemon")
+ "--build-users-group" #$build-group
+ #$@(if use-substitutes?
+ '()
+ '("--no-substitutes"))
+ #$@extra-options)
+
+ ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
+ ;; daemon's $PATH.
+ #:environment-variables
+ (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+ (stop #~(make-kill-destructor)))))))
+
+(define (guix-accounts config)
+ "Return the user accounts and user groups for CONFIG."
+ (match config
+ (($ <guix-configuration> _ build-group build-accounts)
+ (cons (user-group
+ (name build-group)
+ (system? #t)
+
+ ;; Use a fixed GID so that we can create the store with the right
+ ;; owner.
+ (id 30000))
+ (guix-build-accounts build-accounts
+ #:group build-group)))))
+
+(define (guix-activation config)
+ "Return the activation gexp for CONFIG."
+ (match config
+ (($ <guix-configuration> guix build-group build-accounts authorize-key?)
+ ;; Assume that the store has BUILD-GROUP as its group. We could
+ ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
+ ;; chown leads to an entire copy of the tree, which is a bad idea.
+
+ ;; Optionally authorize hydra.gnu.org's key.
+ (and authorize-key?
+ (hydra-key-authorization guix)))))
+
+(define guix-service-type
+ (service-type
+ (name 'guix)
+ (extensions
+ (list (service-extension dmd-root-service-type guix-dmd-service)
+ (service-extension account-service-type guix-accounts)
+ (service-extension activation-service-type guix-activation)))))
+
+(define* (guix-service #:optional (config %default-guix-configuration))
+ "Return a service that runs the Guix build daemon according to
+@var{config}."
+ (service guix-service-type config))
+
+
+;;;
+;;; Udev.
+;;;
+
+(define-record-type* <udev-configuration>
+ udev-configuration make-udev-configuration
+ udev-configuration?
+ (udev udev-configuration-udev ;<package>
+ (default udev))
+ (rules udev-configuration-rules ;list of <package>
+ (default '())))
(define (udev-rules-union packages)
"Return the union of the @code{lib/udev/rules.d} directories found in each
@@ -727,118 +879,150 @@ item of @var{packages}."
KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
#:modules '((guix build utils))))
+(define udev-dmd-service
+ ;; Return a <dmd-service> for UDEV with RULES.
+ (match-lambda
+ (($ <udev-configuration> udev rules)
+ (let* ((rules (udev-rules-union (cons* udev (kvm-udev-rule) rules)))
+ (udev.conf (computed-file "udev.conf"
+ #~(call-with-output-file #$output
+ (lambda (port)
+ (format port
+ "udev_rules=\"~a/lib/udev/rules.d\"\n"
+ #$rules))))))
+ (list
+ (dmd-service
+ (provision '(udev))
+
+ ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
+ ;; be added: see
+ ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
+ (requirement '(root-file-system))
+
+ (documentation "Populate the /dev directory, dynamically.")
+ (start #~(lambda ()
+ (define find
+ (@ (srfi srfi-1) find))
+
+ (define udevd
+ ;; Choose the right 'udevd'.
+ (find file-exists?
+ (map (lambda (suffix)
+ (string-append #$udev suffix))
+ '("/libexec/udev/udevd" ;udev
+ "/sbin/udevd")))) ;eudev
+
+ (define (wait-for-udevd)
+ ;; Wait until someone's listening on udevd's control
+ ;; socket.
+ (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (connect sock PF_UNIX "/run/udev/control")
+ (close-port sock))
+ (lambda args
+ (format #t "waiting for udevd...~%")
+ (usleep 500000)
+ (try))))))
+
+ ;; Allow udev to find the modules.
+ (setenv "LINUX_MODULE_DIRECTORY"
+ "/run/booted-system/kernel/lib/modules")
+
+ ;; The first one is for udev, the second one for eudev.
+ (setenv "UDEV_CONFIG_FILE" #$udev.conf)
+ (setenv "EUDEV_RULES_DIRECTORY"
+ (string-append #$rules "/lib/udev/rules.d"))
+
+ (let ((pid (primitive-fork)))
+ (case pid
+ ((0)
+ (exec-command (list udevd)))
+ (else
+ ;; Wait until udevd is up and running. This
+ ;; appears to be needed so that the events
+ ;; triggered below are actually handled.
+ (wait-for-udevd)
+
+ ;; Trigger device node creation.
+ (system* (string-append #$udev "/bin/udevadm")
+ "trigger" "--action=add")
+
+ ;; Wait for things to settle down.
+ (system* (string-append #$udev "/bin/udevadm")
+ "settle")
+ pid)))))
+ (stop #~(make-kill-destructor))
+
+ ;; When halting the system, 'udev' is actually killed by
+ ;; 'user-processes', i.e., before its own 'stop' method was called.
+ ;; Thus, make sure it is not respawned.
+ (respawn? #f)))))))
+
+(define udev-service-type
+ (service-type (name 'udev)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ udev-dmd-service)))
+
+ (compose concatenate) ;concatenate the list of rules
+ (extend (lambda (config rules)
+ (match config
+ (($ <udev-configuration> udev initial-rules)
+ (udev-configuration
+ (udev udev)
+ (rules (append initial-rules rules)))))))))
+
(define* (udev-service #:key (udev eudev) (rules '()))
"Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
extra rules from the packages listed in @var{rules}."
- (let* ((rules (udev-rules-union (cons* udev
- (kvm-udev-rule)
- rules)))
- (udev.conf (computed-file "udev.conf"
- #~(call-with-output-file #$output
- (lambda (port)
- (format port
- "udev_rules=\"~a/lib/udev/rules.d\"\n"
- #$rules))))))
- (service
- (provision '(udev))
-
- ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
- ;; be added: see
- ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
- (requirement '(root-file-system))
-
- (documentation "Populate the /dev directory, dynamically.")
- (start #~(lambda ()
- (define find
- (@ (srfi srfi-1) find))
-
- (define udevd
- ;; Choose the right 'udevd'.
- (find file-exists?
- (map (lambda (suffix)
- (string-append #$udev suffix))
- '("/libexec/udev/udevd" ;udev
- "/sbin/udevd")))) ;eudev
-
- (define (wait-for-udevd)
- ;; Wait until someone's listening on udevd's control
- ;; socket.
- (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
- (let try ()
- (catch 'system-error
- (lambda ()
- (connect sock PF_UNIX "/run/udev/control")
- (close-port sock))
- (lambda args
- (format #t "waiting for udevd...~%")
- (usleep 500000)
- (try))))))
-
- ;; Allow udev to find the modules.
- (setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
-
- ;; The first one is for udev, the second one for eudev.
- (setenv "UDEV_CONFIG_FILE" #$udev.conf)
- (setenv "EUDEV_RULES_DIRECTORY"
- (string-append #$rules "/lib/udev/rules.d"))
-
- (let ((pid (primitive-fork)))
- (case pid
- ((0)
- (exec-command (list udevd)))
- (else
- ;; Wait until udevd is up and running. This
- ;; appears to be needed so that the events
- ;; triggered below are actually handled.
- (wait-for-udevd)
-
- ;; Trigger device node creation.
- (system* (string-append #$udev "/bin/udevadm")
- "trigger" "--action=add")
-
- ;; Wait for things to settle down.
- (system* (string-append #$udev "/bin/udevadm")
- "settle")
- pid)))))
- (stop #~(make-kill-destructor))
-
- ;; When halting the system, 'udev' is actually killed by
- ;; 'user-processes', i.e., before its own 'stop' method was
- ;; called. Thus, make sure it is not respawned.
- (respawn? #f))))
+ (service udev-service-type
+ (udev-configuration (udev udev) (rules rules))))
+
+(define device-mapping-service-type
+ (dmd-service-type
+ (match-lambda
+ ((target open close)
+ (dmd-service
+ (provision (list (symbol-append 'device-mapping- (string->symbol target))))
+ (requirement '(udev))
+ (documentation "Map a device node using Linux's device mapper.")
+ (start #~(lambda () #$open))
+ (stop #~(lambda _ (not #$close)))
+ (respawn? #f))))))
(define (device-mapping-service target open close)
"Return a service that maps device @var{target}, a string such as
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
gexp, to open it, and evaluate @var{close} to close it."
- (service
- (provision (list (symbol-append 'device-mapping- (string->symbol target))))
- (requirement '(udev))
- (documentation "Map a device node using Linux's device mapper.")
- (start #~(lambda () #$open))
- (stop #~(lambda _ (not #$close)))
- (respawn? #f)))
+ (service device-mapping-service-type
+ (list target open close)))
+
+(define swap-service-type
+ (dmd-service-type
+ (lambda (device)
+ (define requirement
+ (if (string-prefix? "/dev/mapper/" device)
+ (list (symbol-append 'device-mapping-
+ (string->symbol (basename device))))
+ '()))
+
+ (dmd-service
+ (provision (list (symbol-append 'swap- (string->symbol device))))
+ (requirement `(udev ,@requirement))
+ (documentation "Enable the given swap device.")
+ (start #~(lambda ()
+ (restart-on-EINTR (swapon #$device))
+ #t))
+ (stop #~(lambda _
+ (restart-on-EINTR (swapoff #$device))
+ #f))
+ (respawn? #f)))))
(define (swap-service device)
"Return a service that uses @var{device} as a swap device."
- (define requirement
- (if (string-prefix? "/dev/mapper/" device)
- (list (symbol-append 'device-mapping-
- (string->symbol (basename device))))
- '()))
-
- (service
- (provision (list (symbol-append 'swap- (string->symbol device))))
- (requirement `(udev ,@requirement))
- (documentation "Enable the given swap device.")
- (start #~(lambda ()
- (restart-on-EINTR (swapon #$device))
- #t))
- (stop #~(lambda _
- (restart-on-EINTR (swapoff #$device))
- #f))
- (respawn? #f)))
+ (service swap-service-type device))
(define %base-services
;; Convenience variable holding the basic services.
@@ -873,9 +1057,6 @@ This is the GNU operating system, welcome!\n\n")))
;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
;; used, so enable them by default. The FUSE and ALSA rules are
;; less critical, but handy.
- ;;
- ;; XXX Keep this in sync with the 'udev-service' call in
- ;; %desktop-services.
(udev-service #:rules (list lvm2 fuse alsa-utils crda)))))
;;; base.scm ends here
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-25 11:49:04 +0000