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.scm219
1 files changed, 181 insertions, 38 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d6c1707c6a..dc0161408b 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -24,11 +24,15 @@
#:use-module ((gnu packages base)
#:select (glibc-final))
#:use-module (gnu packages package-management)
+ #:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 format)
- #:export (host-name-service
+ #:export (root-file-system-service
+ file-system-service
+ user-processes-service
+ host-name-service
mingetty-service
nscd-service
syslog-service
@@ -42,14 +46,148 @@
;;;
;;; 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.)
+
+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)))))
+
+(define* (file-system-service device target type
+ #:key (check? #t) options)
+ "Return a service that mounts DEVICE on TARGET as a file system TYPE with
+OPTIONS. When CHECK? is true, check the file system before mounting it."
+ (with-monad %store-monad
+ (return
+ (service
+ (provision (list (symbol-append 'file-system- (string->symbol target))))
+ (requirement '(root-file-system))
+ (documentation "Check, mount, and unmount the given file system.")
+ (start #~(lambda args
+ #$(if check?
+ #~(check-file-system #$device #$type)
+ #~#t)
+ (mount #$device #$target #$type 0 #$options)
+ #t))
+ (stop #~(lambda args
+ ;; Normally there are no processes left at this point, so
+ ;; TARGET can be safely unmounted.
+ (umount #$target)
+ #f))))))
+
+(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 2))
+ "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.
+
+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))))
+ '()))
+
+ ;; When this happens, all the processes have been
+ ;; killed, including 'deco', so DMD-OUTPUT-PORT and
+ ;; thus CURRENT-OUTPUT-PORT are dangling.
+ (call-with-output-file "/dev/console"
+ (lambda (port)
+ (display "sending all processes the TERM signal\n"
+ port)))
+
+ (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)))
+
+ (display "all processes have been terminated\n")
+ #f))
+ (respawn? #f)))))
+
(define (host-name-service name)
"Return a service that sets the host name to NAME."
(with-monad %store-monad
(return (service
(documentation "Initialize the machine's host name.")
(provision '(host-name))
- (start `(lambda _
- (sethostname ,name)))
+ (start #~(lambda _
+ (sethostname #$name)))
(respawn? #f)))))
(define* (mingetty-service tty
@@ -57,8 +195,7 @@
(motd (text-file "motd" "Welcome.\n"))
(allow-empty-passwords? #t))
"Return a service to run mingetty on TTY."
- (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty"))
- (motd motd))
+ (mlet %store-monad ((motd motd))
(return
(service
(documentation (string-append "Run mingetty on " tty "."))
@@ -66,12 +203,12 @@
;; Since the login prompt shows the host name, wait for the 'host-name'
;; service to be done.
- (requirement '(host-name))
+ (requirement '(user-processes host-name))
- (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
- (stop `(make-kill-destructor))
- (inputs `(("mingetty" ,mingetty)
- ("motd" ,motd)))
+ (start #~(make-forkexec-constructor
+ (string-append #$mingetty "/sbin/mingetty")
+ "--noclear" #$tty))
+ (stop #~(make-kill-destructor))
(pam-services
;; Let 'login' be known to PAM. All the mingetty services will have
@@ -83,16 +220,23 @@
(define* (nscd-service #:key (glibc glibc-final))
"Return a service that runs libc's name service cache daemon (nscd)."
- (mlet %store-monad ((nscd (package-file glibc "sbin/nscd")))
+ (with-monad %store-monad
(return (service
(documentation "Run libc's name service cache daemon (nscd).")
(provision '(nscd))
- (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"
- "--foreground"))
- (stop `(make-kill-destructor))
+ (requirement '(user-processes))
- (respawn? #f)
- (inputs `(("glibc" ,glibc)))))))
+ (activate #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/run/nscd")))
+
+ (start
+ #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd")
+ "-f" "/dev/null"
+ "--foreground"))
+ (stop #~(make-kill-destructor))
+
+ (respawn? #f)))))
(define (syslog-service)
"Return a service that runs 'syslogd' with reasonable default settings."
@@ -120,21 +264,22 @@
")
(mlet %store-monad
- ((syslog.conf (text-file "syslog.conf" contents))
- (syslogd (package-file inetutils "libexec/syslogd")))
+ ((syslog.conf (text-file "syslog.conf" contents)))
(return
(service
(documentation "Run the syslog daemon (syslogd).")
(provision '(syslogd))
- (start `(make-forkexec-constructor ,syslogd "--no-detach"
- "--rcfile" ,syslog.conf))
- (stop `(make-kill-destructor))
- (inputs `(("inetutils" ,inetutils)
- ("syslog.conf" ,syslog.conf)))))))
+ (requirement '(user-processes))
+ (start
+ #~(make-forkexec-constructor (string-append #$inetutils
+ "/libexec/syslogd")
+ "--no-detach"
+ "--rcfile" #$syslog.conf))
+ (stop #~(make-kill-destructor))))))
(define* (guix-build-accounts count #:key
+ (group "guixbuild")
(first-uid 30001)
- (gid 30000)
(shadow shadow))
"Return a list of COUNT user accounts for Guix build users, with UIDs
starting at FIRST-UID, and under GID."
@@ -143,34 +288,32 @@ starting at FIRST-UID, and under GID."
(lambda (n)
(user-account
(name (format #f "guixbuilder~2,'0d" n))
- (password "!")
(uid (+ first-uid n -1))
- (gid gid)
+ (group group)
(comment (format #f "Guix Build User ~2d" n))
(home-directory "/var/empty")
- (shell (package-file shadow "sbin/nologin"))
- (inputs `(("shadow" ,shadow)))))
+ (shell #~(string-append #$shadow "/sbin/nologin"))))
1+
1))))
(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
- (build-user-gid 30000) (build-accounts 10))
+ (build-accounts 10))
"Return a service that runs the build daemon from GUIX, and has
BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
- (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon"))
- (accounts (guix-build-accounts build-accounts
- #:gid build-user-gid)))
+ (mlet %store-monad ((accounts (guix-build-accounts build-accounts
+ #:group builder-group)))
(return (service
(provision '(guix-daemon))
- (start `(make-forkexec-constructor ,daemon
- "--build-users-group"
- ,builder-group))
- (stop `(make-kill-destructor))
- (inputs `(("guix" ,guix)))
+ (requirement '(user-processes))
+ (start
+ #~(make-forkexec-constructor (string-append #$guix
+ "/bin/guix-daemon")
+ "--build-users-group"
+ #$builder-group))
+ (stop #~(make-kill-destructor))
(user-accounts accounts)
(user-groups (list (user-group
(name builder-group)
- (id build-user-gid)
(members (map user-account-name
user-accounts)))))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-08-07 00:38:56 +0000