civodul pushed a commit to branch main
in repository shepherd.
commit 4d8161fbede998ad813cbecd317c27b38f400253
Author: Ludovic Courtès <[email protected]>
AuthorDate: Sun Apr 13 11:52:41 2025 +0200
shepherd: Open the socket before starting the root service.
* modules/shepherd.scm (call-with-server-socket): Remove call to
‘stop-service’. Call ‘exit’ on failure.
(run-daemon): Replace #:socket-file with #:socket and remove call to
‘call-with-server-socket’.
(main): Wrap body in ‘call-with-server-socket’.
* tests/basic.sh: Test it.
---
modules/shepherd.scm | 273 +++++++++++++++++++++++++--------------------------
tests/basic.sh | 4 +-
2 files changed, 138 insertions(+), 139 deletions(-)
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 68e402b..a1bfebb 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -62,16 +62,13 @@ socket file at FILE-NAME upon exit of PROC. Return the
values of PROC."
(report-error (l10n "while opening socket '~a': ~a: ~a")
file-name proc
(strerror (system-error-errno args)))
- ;; Stop services that were started from the config file
- ;; and quit.
- (stop-service root-service)))))))
- (and sock
- (catch #t
- (lambda ()
- (proc sock))
- (lambda args
- (close sock)
- (apply throw args))))))
+ (exit 1)))))))
+ (catch #t
+ (lambda ()
+ (proc sock))
+ (lambda args
+ (close sock)
+ (apply throw args)))))
(define (maybe-signal-port signals)
"Return a signal port for SIGNALS, using 'signalfd' on GNU/Linux, or #f if
@@ -213,7 +210,7 @@ configuration file '~a': ~s")
(const 'timeout)))))
(define* (run-daemon #:key (config-file (default-config-file))
- socket-file pid-file signal-port poll-services?)
+ socket pid-file signal-port poll-services?)
(define (signal-thunk signal-port)
;; Thunk that waits for signals (particularly SIGCHLD) and handles them.
(if signal-port
@@ -286,36 +283,33 @@ configuration file '~a': ~s")
;; prematurely.
(sigaction SIGPIPE SIG_IGN)
- (if (not socket-file)
+ (if (not socket)
;; Get commands from the standard input port.
(process-textual-commands (current-input-port))
;; Process the data arriving at a socket.
- (call-with-server-socket
- socket-file
- (lambda (sock)
-
- ;; Possibly write out our PID, which means we're ready to accept
- ;; connections. XXX: What if we daemonized already?
- (match pid-file
- ((? string? file)
- (with-atomic-file-output pid-file
- (cute display (getpid) <>)))
- (#t (display (getpid)))
- (_ #t))
-
- ;; Enter some sort of a REPL for commands.
- (let next-command ()
- (match (accept sock (logior SOCK_NONBLOCK SOCK_CLOEXEC))
- ((command-source . client-address)
- (setvbuf command-source 'block 1024)
- (set-port-encoding! command-source "UTF-8")
- (set-port-conversion-strategy! command-source 'error)
- (spawn-fiber
- (lambda ()
- (process-connection command-source))))
- (_ #f))
-
- (next-command))))))
+ (begin
+ ;; Possibly write out our PID, which means we're ready to accept
+ ;; connections.
+ (match pid-file
+ ((? string? file)
+ (with-atomic-file-output pid-file
+ (cute display (getpid) <>)))
+ (#t (display (getpid)))
+ (_ #t))
+
+ ;; Enter some sort of a REPL for commands.
+ (let next-command ()
+ (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
+ ((command-source . client-address)
+ (setvbuf command-source 'block 1024)
+ (set-port-encoding! command-source "UTF-8")
+ (set-port-conversion-strategy! command-source 'error)
+ (spawn-fiber
+ (lambda ()
+ (process-connection command-source))))
+ (_ #f))
+
+ (next-command)))))
;; In Guile 3.0.x, 'call-with-input-file' & co. do not open their files as
;; O_CLOEXEC. The two procedures below address that.
@@ -497,107 +491,110 @@ fork in the child process."
(unless (getenv "GUILE_WARN_DEPRECATED")
(debug-enable 'warn-deprecated))
- ;; Enable logging as first action.
- (parameterize ((log-output-port (cdr log-input+output))
-
- ;; Send warnings such as deprecation warnings to the log.
- (current-warning-port (cdr log-input+output))
-
- (%current-logfile-date-format
- (if syslog?
- "" ;for the "built-in" logger
- default-logfile-date-format))
- (%current-service-output-port
- ;; Send output to log and clients.
- (make-shepherd-output-port
- (if (or silent? syslog?)
- ;; By default we'd write both to /dev/log and to
- ;; stdout. Redirect stdout to the bitbucket so we
- ;; don't log twice.
- (%make-void-port "w")
- (current-output-port))))
-
- ;; In Guile 3.0.10, calling 'environ' from the top-level
- ;; triggers a warning so do it from here.
- (default-environment-variables (environ)))
-
- (parameterize ((current-output-port (%current-service-output-port)))
- (set-port-encoding! (log-output-port) "UTF-8")
- (set-port-encoding! (%current-service-output-port) "UTF-8")
-
- ;; Log provenance info.
- (format #t "~a ~a (Guile ~a, ~a)~%"
- package-name Version
- (version) %host-type)
-
- (when (= 1 (getpid))
- ;; When running as PID 1, disable hard reboots upon ctrl-alt-del.
- ;; Instead, the kernel will send us SIGINT so that we can gracefully
- ;; shut down. See ctrlaltdel(8) and kernel/reboot.c.
- (catch 'system-error
+ (call-with-server-socket
+ socket-file
+ (lambda (socket)
+ ;; Enable logging as first action.
+ (parameterize ((log-output-port (cdr log-input+output))
+
+ ;; Send warnings such as deprecation warnings to the log.
+ (current-warning-port (cdr log-input+output))
+
+ (%current-logfile-date-format
+ (if syslog?
+ "" ;for the "built-in" logger
+ default-logfile-date-format))
+ (%current-service-output-port
+ ;; Send output to log and clients.
+ (make-shepherd-output-port
+ (if (or silent? syslog?)
+ ;; By default we'd write both to /dev/log and to
+ ;; stdout. Redirect stdout to the bitbucket so we
+ ;; don't log twice.
+ (%make-void-port "w")
+ (current-output-port))))
+
+ ;; In Guile 3.0.10, calling 'environ' from the top-level
+ ;; triggers a warning so do it from here.
+ (default-environment-variables (environ)))
+
+ (parameterize ((current-output-port (%current-service-output-port)))
+ (set-port-encoding! (log-output-port) "UTF-8")
+ (set-port-encoding! (%current-service-output-port) "UTF-8")
+
+ ;; Log provenance info.
+ (format #t "~a ~a (Guile ~a, ~a)~%"
+ package-name Version
+ (version) %host-type)
+
+ (when (= 1 (getpid))
+ ;; When running as PID 1, disable hard reboots upon ctrl-alt-del.
+ ;; Instead, the kernel will send us SIGINT so that we can
gracefully
+ ;; shut down. See ctrlaltdel(8) and kernel/reboot.c.
+ (catch 'system-error
+ (lambda ()
+ (disable-reboot-on-ctrl-alt-del))
+ (lambda args
+ (let ((err (system-error-errno args)))
+ ;; When in a separate PID namespace, we get EINVAL (see
+ ;; 'reboot_pid_ns' in kernel/pid_namespace.c.) We get
EPERM in
+ ;; a user namespace that lacks CAP_SYS_BOOT.
+ ;; ENOSYS is returned in runc environments due to seccomp
+ ;; defaults:
<https://github.com/opencontainers/runc/pull/2750>.
+ (unless (member err (list EINVAL EPERM ENOSYS))
+ (apply throw args)))))
+
+ ;; Load the SIGSEGV/SIGABRT handler. This is what allows PID 1 to
+ ;; dump core on "/", should something go wrong.
+ (false-if-exception
+ (dynamic-link (string-append %pkglibdir "/crash-handler"))))
+
+ ;; Run Fibers in such a way that it does not create any POSIX
thread,
+ ;; because POSIX threads and 'fork' cannot be used together.
+ (run-fibers
(lambda ()
- (disable-reboot-on-ctrl-alt-del))
- (lambda args
- (let ((err (system-error-errno args)))
- ;; When in a separate PID namespace, we get EINVAL (see
- ;; 'reboot_pid_ns' in kernel/pid_namespace.c.) We get EPERM in
- ;; a user namespace that lacks CAP_SYS_BOOT.
- ;; ENOSYS is returned in runc environments due to seccomp
- ;; defaults:
<https://github.com/opencontainers/runc/pull/2750>.
- (unless (member err (list EINVAL EPERM ENOSYS))
- (apply throw args)))))
-
- ;; Load the SIGSEGV/SIGABRT handler. This is what allows PID 1 to
- ;; dump core on "/", should something go wrong.
- (false-if-exception
- (dynamic-link (string-append %pkglibdir "/crash-handler"))))
-
- ;; Run Fibers in such a way that it does not create any POSIX thread,
- ;; because POSIX threads and 'fork' cannot be used together.
- (run-fibers
- (lambda ()
- (with-process-monitor
- (with-service-registry
-
- ;; Register and start the 'root' service.
- (register-services (list root-service))
- (start-service root-service)
-
- (if syslog?
- (spawn-service-system-logger (car log-input+output)
- #:service root-service)
- (spawn-service-file-logger (or logfile
- (if (= 1 (getpid))
- (system-default-log-file)
- (user-default-log-file)))
- (car log-input+output)
- #:service root-service))
-
- ;; Replace the default 'system*' binding with one that
- ;; cooperates instead of blocking on 'waitpid'. Replace
- ;; 'primitive-load' (in C as of 3.0.9) with one that does
- ;; not introduce a continuation barrier. Replace 'sleep' to
- ;; avoid blocking in user code such as 'start' methods.
- (replace-core-bindings!
- (newline (lambda* (#:optional (port (current-output-port)))
- ;; As of Guile 3.0.10, 'newline' is written in C
- ;; and thus a continuation barrier. Replace it.
- (put-char port #\newline)))
- (system* (lambda command
- (spawn-command command #:directory (getcwd))))
- (system spawn-shell-command)
- (primitive-load primitive-load*)
- (call-with-input-file call-with-input-file/close-on-exec)
- (call-with-output-file call-with-output-file/close-on-exec)
- ((@ (guile) sleep) (@ (fibers) sleep)))
-
- (run-daemon #:socket-file socket-file
- #:config-file (or config-file (default-config-file))
- #:pid-file pid-file
- #:signal-port signal-port
- #:poll-services? poll-services?))))
- #:parallelism 1 ;don't create POSIX threads
- #:hz 0))))) ;disable preemption, which would require POSIX
threads
+ (with-process-monitor
+ (with-service-registry
+
+ ;; Register and start the 'root' service.
+ (register-services (list root-service))
+ (start-service root-service)
+
+ (if syslog?
+ (spawn-service-system-logger (car log-input+output)
+ #:service root-service)
+ (spawn-service-file-logger (or logfile
+ (if (= 1 (getpid))
+
(system-default-log-file)
+
(user-default-log-file)))
+ (car log-input+output)
+ #:service root-service))
+
+ ;; Replace the default 'system*' binding with one that
+ ;; cooperates instead of blocking on 'waitpid'. Replace
+ ;; 'primitive-load' (in C as of 3.0.9) with one that does
+ ;; not introduce a continuation barrier. Replace 'sleep' to
+ ;; avoid blocking in user code such as 'start' methods.
+ (replace-core-bindings!
+ (newline (lambda* (#:optional (port (current-output-port)))
+ ;; As of Guile 3.0.10, 'newline' is written in C
+ ;; and thus a continuation barrier. Replace it.
+ (put-char port #\newline)))
+ (system* (lambda command
+ (spawn-command command #:directory (getcwd))))
+ (system spawn-shell-command)
+ (primitive-load primitive-load*)
+ (call-with-input-file call-with-input-file/close-on-exec)
+ (call-with-output-file call-with-output-file/close-on-exec)
+ ((@ (guile) sleep) (@ (fibers) sleep)))
+
+ (run-daemon #:socket socket
+ #:config-file (or config-file
(default-config-file))
+ #:pid-file pid-file
+ #:signal-port signal-port
+ #:poll-services? poll-services?))))
+ #:parallelism 1 ;don't create POSIX threads
+ #:hz 0))))))) ;disable preemption, which would require POSIX
threads
(define* (quit-exception-handler key #:optional value)
"Handle the 'quit' exception, rebooting if we're running as root."
diff --git a/tests/basic.sh b/tests/basic.sh
index 69b3a83..2214e78 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -1,5 +1,5 @@
# GNU Shepherd --- Test basic communication capabilities.
-# Copyright © 2013-2014, 2016-2019, 2022-2024 Ludovic Courtès <[email protected]>
+# Copyright © 2013-2014, 2016-2019, 2022-2025 Ludovic Courtès <[email protected]>
# Copyright © 2016 Mathieu Lirzin <[email protected]>
# Copyright © 2014 Alex Sassmannshausen <[email protected]>
#
@@ -74,6 +74,8 @@ cat > "$conf"<<EOF
#:respawn? #f)))
EOF
+shepherd -I -s /does/not/exist/sock -c "$conf" && false
+
rm -f "$pid"
shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &
