From be1c2c54d9f918f50f71c6d32a72d4498c07504c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Sep 2015 09:17:31 +0200 Subject: system: Make service procedures non-monadic. * gnu/services/avahi.scm (configuration-file): Use 'plain-file' instead of 'text-file'. (avahi-service): Turn into a regular procedure that returns a . * gnu/services/base.scm (root-file-system-service, file-system-service, user-unmount-service, user-processes-service, host-name-service, console-keymap-service, console-font-service, mingetty-service, nscd.conf-file, nscd-service): Likewise. (%default-syslog.conf): New variable. (syslog-service): Use it. Turn into a regular procedure. (guix-service, udev-rules-union, kvm-udev-rule, udev-service, device-mapping-service, swap-service): Likewise. * gnu/services/databases.scm (%default-postgres-hba, %default-postgres-ident): Use 'plain-file' instead of 'text-file'. (%default-postgres-config): Use 'mixed-text-file' instead of 'text-file*'. (postgresql-service): Use 'program-file' instead of 'gexp->script'. Turn into a regular procedure. * gnu/services/desktop.scm (dbus-configuration-directory): Use 'computed-file' instead of 'gexp->derivation'. (upower-configuration-file, geoclue-configuration-file, elogind-configuration-file): Use 'plain-file' instead of 'text-file'. (dbus-service, upower-service, colord-service, geoclue-service, polkit-service, elogind-service): Turn into regular procedures. (%desktop-services): Remove use of 'mlet' when iterating on %BASE-SERVICES. * gnu/services/lirc.scm (lirc-service): Turn into a regular procedure. * gnu/services/networking.scm (static-networking-service, dhcp-client-service, ntp-service, tor-service, bitlbee-service, wicd-service): Likewise. * gnu/services/ssh.scm (lsh-service): Likewise. * gnu/services/web.scm (nginx-service): Likewise. * gnu/services/xorg.scm (xorg-configuration-file): Use 'mixed-text-file' instead of 'text-file*'. (xorg-start-command, slim-service): Turn into regular procedures. (xinitrc): Use 'program-file' instead of 'gexp->script'. * gnu/system/install.scm (cow-store-service, configuration-template-service): Turn into regular procedures. * gnu/system.scm (other-file-system-services, device-mapping-services, swap-services, essential-services, operating-system-services, user-shells, operating-system-accounts): Remove now unnecessary 'mlet' and turn into regular procedures. (operating-system-etc-directory, operating-system-activation-script, operating-system-boot-script): Adjust accordingly. * doc/guix.texi (Base Services, Networking Services, X Window, Desktop Services, Database Services, Web Services, Various Services, Name Service Switch): Adjust accordingly. --- gnu/services/base.scm | 908 ++++++++++++++++++++++++-------------------------- 1 file changed, 443 insertions(+), 465 deletions(-) (limited to 'gnu/services/base.scm') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 865d461a1e..799526ce2a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -35,7 +35,6 @@ (define-module (gnu services base) #:use-module ((gnu build file-systems) #:select (mount-flags->bit-mask)) #:use-module (guix gexp) - #:use-module (guix monads) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -80,41 +79,39 @@ (define (root-file-system-service) 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." - (with-monad %store-monad - (return - (service - (documentation "Take care of the root file system.") - (provision '(root-file-system)) - (start #~(const #t)) - (stop #~(lambda _ - ;; Return #f if successfully stopped. - (sync) - - (call-with-blocked-asyncs - (lambda () - (let ((null (%make-void-port "w"))) - ;; Close 'dmd.log'. - (display "closing log\n") - ;; XXX: Ideally we'd use 'stop-logging', but that one - ;; doesn't actually close the port as of dmd 0.1. - (close-port (@@ (dmd comm) log-output-port)) - (set! (@@ (dmd comm) log-output-port) null) - - ;; Redirect the default output ports.. - (set-current-output-port null) - (set-current-error-port null) - - ;; Close /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; At this point, there are no open files left, so the - ;; root file system can be re-mounted read-only. - (mount #f "/" #f - (logior MS_REMOUNT MS_RDONLY) - #:update-mtab? #f) - - #f))))) - (respawn? #f))))) + (service + (documentation "Take care of the root file system.") + (provision '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; Return #f if successfully stopped. + (sync) + + (call-with-blocked-asyncs + (lambda () + (let ((null (%make-void-port "w"))) + ;; Close 'dmd.log'. + (display "closing log\n") + ;; XXX: Ideally we'd use 'stop-logging', but that one + ;; doesn't actually close the port as of dmd 0.1. + (close-port (@@ (dmd comm) log-output-port)) + (set! (@@ (dmd comm) log-output-port) null) + + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) + + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; At this point, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) + (respawn? #f))) (define* (file-system-service device target type #:key (flags '()) (check? #t) @@ -127,79 +124,75 @@ (define* (file-system-service device target type 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." - (with-monad %store-monad - (return - (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 , 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)))))) + (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 , 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 (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." - (with-monad %store-monad - (return - (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 + (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 %do-not-kill-file ;; Name of the file listing PIDs of processes that must survive when halting @@ -217,86 +210,84 @@ (define* (user-processes-service requirements #:key (grace-delay 4)) All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." - (with-monad %store-monad - (return (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 . - (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\ + (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 . + (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)))) + pids) + (sleep* 2) + (wait)))) - (display "all processes have been terminated\n") - #f)) - (respawn? #f))))) + (display "all processes have been terminated\n") + #f)) + (respawn? #f))) (define (host-name-service name) "Return a service that sets the host name to @var{name}." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start #~(lambda _ - (sethostname #$name))) - (respawn? #f))))) + (service + (documentation "Initialize the machine's host name.") + (provision '(host-name)) + (start #~(lambda _ + (sethostname #$name))) + (respawn? #f))) (define (unicode-start tty) "Return a gexp to start Unicode support on @var{tty}." @@ -318,16 +309,13 @@ (define (unicode-start tty) (define (console-keymap-service file) "Return a service to load console keymap from @var{file}." - (with-monad %store-monad - (return - (service - (documentation - (string-append "Load console keymap (loadkeys).")) - (provision '(console-keymap)) - (start #~(lambda _ - (zero? (system* (string-append #$kbd "/bin/loadkeys") - #$file)))) - (respawn? #f))))) + (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-font-service tty #:optional (font "LatGrkCyr-8x16")) "Return a service that sets up Unicode support in @var{tty} and loads @@ -336,24 +324,23 @@ (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) ;; 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))) - (with-monad %store-monad - (return (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 + (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* (mingetty-service tty #:key @@ -379,38 +366,36 @@ (define* (mingetty-service tty tool suite.) @var{motd} is a file-like object to use as the ``message of the day''." - (with-monad %store-monad - (return - (service - (documentation (string-append "Run mingetty on " 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))))))) + (service + (documentation (string-append "Run mingetty on " 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))))) (define-record-type* nscd-configuration make-nscd-configuration @@ -472,44 +457,44 @@ (define (nscd.conf-file config) @code{} object." (define cache->config (match-lambda - (($ (= symbol->string database) - positive-ttl negative-ttl size check-files? - persistent? shared? max-size propagate?) - (string-append "\nenable-cache\t" database "\tyes\n" - - "positive-time-to-live\t" database "\t" - (number->string positive-ttl) "\n" - "negative-time-to-live\t" database "\t" - (number->string negative-ttl) "\n" - "suggested-size\t" database "\t" - (number->string size) "\n" - "check-files\t" database "\t" - (if check-files? "yes\n" "no\n") - "persistent\t" database "\t" - (if persistent? "yes\n" "no\n") - "shared\t" database "\t" - (if shared? "yes\n" "no\n") - "max-db-size\t" database "\t" - (number->string max-size) "\n" - "auto-propagate\t" database "\t" - (if propagate? "yes\n" "no\n"))))) + (($ (= symbol->string database) + positive-ttl negative-ttl size check-files? + persistent? shared? max-size propagate?) + (string-append "\nenable-cache\t" database "\tyes\n" + + "positive-time-to-live\t" database "\t" + (number->string positive-ttl) "\n" + "negative-time-to-live\t" database "\t" + (number->string negative-ttl) "\n" + "suggested-size\t" database "\t" + (number->string size) "\n" + "check-files\t" database "\t" + (if check-files? "yes\n" "no\n") + "persistent\t" database "\t" + (if persistent? "yes\n" "no\n") + "shared\t" database "\t" + (if shared? "yes\n" "no\n") + "max-db-size\t" database "\t" + (number->string max-size) "\n" + "auto-propagate\t" database "\t" + (if propagate? "yes\n" "no\n"))))) (match config (($ log-file debug-level caches) - (text-file "nscd.conf" - (string-append "\ + (plain-file "nscd.conf" + (string-append "\ # Configuration of libc's name service cache daemon (nscd).\n\n" - (if log-file - (string-append "logfile\t" log-file) - "") - "\n" - (if debug-level - (string-append "debug-level\t" - (number->string debug-level)) - "") - "\n" - (string-concatenate - (map cache->config caches))))))) + (if log-file + (string-append "logfile\t" log-file) + "") + "\n" + (if debug-level + (string-append "debug-level\t" + (number->string debug-level)) + "") + "\n" + (string-concatenate + (map cache->config caches))))))) (define* (nscd-service #:optional (config %nscd-default-configuration) #:key (glibc (canonical-package glibc)) @@ -518,39 +503,35 @@ (define* (nscd-service #:optional (config %nscd-default-configuration) given @var{config}---an @code{} object. Optionally, @code{#:name-services} is a list of packages that provide name service switch (NSS) modules needed by nscd. @xref{Name Service Switch}, for an example." - (mlet %store-monad ((nscd.conf (nscd.conf-file config))) - (return (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 #$glibc "/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* (syslog-service #:key config-file) - "Return a service that runs @code{syslogd}. -If configuration file name @var{config-file} is not specified, use some -reasonable default settings." - - ;; Snippet adapted from the GNU inetutils manual. - (define contents " + (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 #$glibc "/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)))) + +;; Snippet adapted from the GNU inetutils manual. +(define %default-syslog.conf + (plain-file "syslog.conf" " # Log all error messages, authentication messages of # level notice or higher and anything of level err or # higher to the console. @@ -569,20 +550,19 @@ (define contents " # Log all the mail messages in one place. mail.* /var/log/maillog -") - - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents))) - (return - (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" #$(or config-file syslog.conf)))) - (stop #~(make-kill-destructor)))))) +")) +(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)))) (define* (guix-build-accounts count #:key (group "guixbuild") @@ -658,36 +638,34 @@ (define activate (and authorize-hydra-key? (hydra-key-authorization guix))) - (with-monad %store-monad - (return (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))))) + (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 (udev-rules-union packages) "Return the union of the @code{lib/udev/rules.d} directories found in each @@ -712,124 +690,125 @@ (define (rules-sub-directory directory) (union-build (string-append #$output "/lib/udev/rules.d") (filter-map rules-sub-directory '#$packages)))) - (gexp->derivation "udev-rules" build - #:modules '((guix build union) - (guix build utils)) - #:local-build? #t)) + (computed-file "udev-rules" build + #:modules '((guix build union) + (guix build utils)))) (define* (kvm-udev-rule) "Return a directory with a udev rule that changes the group of @file{/dev/kvm} to \"kvm\" and makes it #o660." ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by ;; ourselves. - (gexp->derivation "kvm-udev-rules" - #~(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 "/90-kvm.rules") - (lambda (port) - ;; Build users are part of the "kvm" group, so we - ;; can fearlessly make /dev/kvm 660 (see - ;; , for background.) - (display "\ + (computed-file "kvm-udev-rules" + #~(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 "/90-kvm.rules") + (lambda (port) + ;; Build users are part of the "kvm" group, so we + ;; can fearlessly make /dev/kvm 660 (see + ;; , for background.) + (display "\ KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) - #:modules '((guix build utils)))) + #:modules '((guix build utils)))) (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}." - (mlet* %store-monad ((kvm (kvm-udev-rule)) - (rules (udev-rules-union (cons* udev kvm rules))) - (udev.conf (text-file* "udev.conf" - "udev_rules=\"" rules - "/lib/udev/rules.d\"\n"))) - (return (service - (provision '(udev)) - - ;; Udev needs /dev to be a 'devtmpfs' mount so that new device - ;; nodes can be added: see - ;; . - (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))))) + (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 + ;; . + (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 (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." - (with-monad %store-monad - (return (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 + (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 (swap-service device) "Return a service that uses @var{device} as a swap device." @@ -839,18 +818,17 @@ (define requirement (string->symbol (basename device)))) '())) - (with-monad %store-monad - (return (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 + (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 %base-services ;; Convenience variable holding the basic services. -- cgit v1.2.3