[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 04/05: service: ‘make-forkexec-constructor’ & co. return a <p
|
From: |
Ludovic Courtès |
|
Subject: |
[shepherd] 04/05: service: ‘make-forkexec-constructor’ & co. return a <process>. |
|
Date: |
Sun, 31 Dec 2023 10:28:12 -0500 (EST) |
civodul pushed a commit to branch devel
in repository shepherd.
commit 4e3b58e5cdc3fd3c0448f631fc4983224aafc347
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Dec 31 01:17:50 2023 +0100
service: ‘make-forkexec-constructor’ & co. return a <process>.
* modules/shepherd.scm (process-connection): Move below definition of
‘process-command’.
* modules/shepherd/service.scm (<process>): New record type.
(pid->process, process->sexp): New procedures.
(service-controller): Pass ‘start’ and ‘change-value’ values that
match ‘pid?’ through ‘pid->process’. In ‘handle-termination’ handler,
expect VALUE to be a process.
(make-forkexec-constructor): Return a <process> instead of a PID.
(make-kill-destructor): Adjust accordingly.
(check-for-dead-services): Likewise.
* tests/signals.sh: Change #:stop to expect a <process> instead of a PID.
* tests/system-star.sh: Likewise.
---
doc/shepherd.texi | 4 +-
modules/shepherd.scm | 32 +++++++--------
modules/shepherd/service.scm | 96 ++++++++++++++++++++++++++++++++------------
tests/signals.sh | 4 +-
tests/system-star.sh | 5 ++-
5 files changed, 94 insertions(+), 47 deletions(-)
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 51302e7..795de9b 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1065,8 +1065,8 @@ unless they are @code{#f} and supplementary groups to
@var{supplementary-groups} unless they are @code{'()}, and executes
@var{command} (a list of strings.) When
@var{create-session?} is true, the child process creates a new session with
-@code{setsid} and becomes its leader. The result of the procedure will be
-the PID of the child process.
+@code{setsid} and becomes its leader. The result of the procedure will be the
+@code{<process>} record representing the child process.
@quotation Note
This will not work as expected if the process ``daemonizes'' (forks); in
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 424c906..0e01bac 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -518,22 +518,6 @@ fork in the child process."
#:parallelism 1 ;don't create POSIX threads
#:hz 0))))) ;disable preemption, which would require POSIX
threads
-(define (process-connection sock)
- "Process client connection SOCK, reading and processing commands."
- (catch 'system-error
- (lambda ()
- (match (read-command sock)
- ((? shepherd-command? command)
- (process-command command sock))
- (#f ;failed to read a valid command
- #f))
-
- ;; Currently we assume one command per connection.
- (false-if-exception (close sock)))
- (lambda args
- ;; Maybe we got EPIPE while writing to SOCK, or something like that.
- (false-if-exception (close sock)))))
-
(define* (quit-exception-handler key #:optional value)
"Handle the 'quit' exception, rebooting if we're running as root."
;; Note: The 'quit' exception does not necessarily have an associated value:
@@ -636,6 +620,22 @@ while evaluating @var{command}."
(_
(local-output (l10n "Invalid command.")))))
+(define (process-connection sock)
+ "Process client connection SOCK, reading and processing commands."
+ (catch 'system-error
+ (lambda ()
+ (match (read-command sock)
+ ((? shepherd-command? command)
+ (process-command command sock))
+ (#f ;failed to read a valid command
+ #f))
+
+ ;; Currently we assume one command per connection.
+ (false-if-exception (close sock)))
+ (lambda args
+ ;; Maybe we got EPIPE while writing to SOCK, or something like that.
+ (false-if-exception (close sock)))))
+
(define (process-textual-commands port)
"Process textual commands from PORT. 'Textual' means that they're as you
would write them on the 'herd' command line."
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 2bdd297..3c515b7 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -115,6 +115,10 @@
make-inetd-constructor
make-inetd-destructor
+ process?
+ process-id
+ process-command
+
endpoint
endpoint?
endpoint-name
@@ -182,6 +186,30 @@
(define sleep (@ (fibers) sleep))
+;; A process, as started by 'make-forkexec-constructor'.
+(define-record-type <process>
+ (process id command)
+ process?
+ (id process-id) ;integer
+ (command process-command)) ;list of strings
+
+(define (pid->process pid)
+ "Return a @code{<process>} record for @var{pid}."
+ (process pid
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file (string-append "/proc/"
+ (number->string pid)
+ "/cmdline")
+ (lambda (port)
+ (string-tokenize (get-string-all port)
+ (char-set-complement (char-set #\nul))))))
+ (const '()))))
+
+(define-record-type-serializer (process->sexp (process <process>))
+ ;; TODO: Serialize the whole structure so clients can display more info.
+ (process-id process))
+
;; Type of service actions.
(define-record-type <action>
(make-action name proc doc)
@@ -239,9 +267,12 @@ respawned, shows that it has been respawned more than
TIMES in SECONDS."
(and (> (+ last-respawn seconds) now)
(loop (- times 1) rest)))))))
-(define (default-service-termination-handler service pid status)
+(define (default-service-termination-handler service process status)
"Handle the termination of @var{service} by respawning it if applicable.
Log abnormal termination reported by @var{status}."
+ (define pid
+ (process-id process))
+
(unless (zero? status)
;; Most likely something went wrong; log it.
(cond ((status:exit-val status)
@@ -520,17 +551,19 @@ denoting what the service provides."
(((? started-message?) new-value) ;no reply
;; When NEW-VALUE is a procedure, call it to get the actual value and
;; pass it a call back so it can eventually change it.
- (let ((new-value (if (procedure? new-value)
- (new-value
- (lambda (value)
- (put-message channel
- (list *change-value* value))))
- new-value)))
+ (let ((new-value (cond ((procedure? new-value)
+ (new-value
+ (lambda (value)
+ (put-message channel
+ (list *change-value* value)))))
+ ((pid? new-value) ;backward compatibility
+ (pid->process new-value))
+ (else new-value))))
(when new-value
(local-output (l10n "Service ~a running with value ~s.")
(service-canonical-name service) new-value))
- (when (pid? new-value)
- (monitor-service-process service new-value))
+ (when (process? new-value)
+ (monitor-service-process service (process-id new-value)))
(signal-condition! condition)
(let ((new-status (if (and new-value (not (one-shot-service? service)))
@@ -546,11 +579,14 @@ denoting what the service provides."
failures)))))))
(((? change-value-message?) new-value)
- (local-output (l10n "Running value of service ~a changed to ~s.")
- (service-canonical-name service) new-value)
- (when (pid? new-value)
- (monitor-service-process service new-value))
- (loop (value new-value)))
+ (let ((new-value (if (pid? new-value) ;backward compatibility
+ (pid->process new-value)
+ new-value)))
+ (local-output (l10n "Running value of service ~a changed to ~s.")
+ (service-canonical-name service) new-value)
+ (when (process? new-value)
+ (monitor-service-process service (process-id new-value)))
+ (loop (value new-value))))
(('stop reply)
;; Attempt to stop SERVICE, blocking if it is already being stopped.
@@ -622,7 +658,8 @@ denoting what the service provides."
;; doesn't match VALUE (which happens with notifications of processes
;; terminated while stopping the service or shortly after).
(if (or (memq status '(stopping stopped))
- (not (eqv? value pid)))
+ (and (process? value)
+ (not (= (process-id value) pid))))
(loop)
(begin
(spawn-fiber
@@ -1828,8 +1865,8 @@ the current directory to @var{directory}, sets the umask
to
current user to @var{user} and the current group to @var{group} unless they
are @code{#f}, and executes @var{command} (a list of strings.) When
@var{create-session?} is true, the child process creates a new session with
-'setsid' and becomes its leader. The result of the procedure will be the
- PID of the child process.
+@code{setsid} and becomes its leader. The result of the procedure will be the
+@code{<process>} record representing the child process.
When @var{pid-file} is true, it must be the name of a PID file associated with
the process being launched; the return value is the PID read from that file,
@@ -1871,8 +1908,8 @@ terminating process ~a.")
(terminate-process (- pid) SIGTERM)
#f)
((? integer? pid)
- pid))
- pid))))
+ (process pid command)))
+ (process pid command)))))
(define* (make-kill-destructor #:optional (signal SIGTERM)
#:key (grace-period
@@ -1881,7 +1918,14 @@ terminating process ~a.")
given as argument, where @var{signal} defaults to @code{SIGTERM}. If the
process is still running after @var{grace-period} seconds, send it
@code{SIGKILL}. The procedure returns once the process has terminated."
- (lambda (pid . args)
+ (lambda (process . args)
+ (define pid
+ ;; For backward compatibility, accept receiving a PID rather than a
+ ;; <process> record.
+ (if (integer? process)
+ process
+ (process-id process)))
+
;; Kill the whole process group PID belongs to. Don't assume that PID is
;; a process group ID: that's not the case when using #:pid-file, where
;; the process group ID is the PID of the process that "daemonized". If
@@ -2359,7 +2403,7 @@ This must be paired with @code{make-systemd-destructor}."
(append variables
environment-variables)
#:listen-pid-variable? #t
#:resource-limits resource-limits)))
- (change-service-value pid)
+ (change-service-value (process pid command))
(for-each close-port ports))))
sockets))))
@@ -2369,7 +2413,9 @@ This must be paired with @code{make-systemd-destructor}."
@code{make-systemd-constructor}."
(let ((destroy (make-kill-destructor)))
(match-lambda
- ((? integer? pid)
+ ((? process? process)
+ (destroy process))
+ ((? integer? pid) ;backward compatibility
(destroy pid))
(((_ . (? port? socks)) ...)
(for-each close-port socks)
@@ -2917,11 +2963,11 @@ where prctl/PR_SET_CHILD_SUBREAPER is unsupported."
(for-each-service (lambda (service)
(let ((running (service-running-value service)))
- (when (and (integer? running)
- (not (process-exists? running)))
+ (when (and (process? running)
+ (not (process-exists? (process-id
running))))
(local-output (l10n "PID ~a (~a) is dead!")
running (service-canonical-name
service))
- (respawn-service service))))))
+ (respawn-service service))))))
(define %post-daemonize-hook
;; Hook invoked after the 'daemonize' action in the child process.
diff --git a/tests/signals.sh b/tests/signals.sh
index 5081b1c..09f7068 100644
--- a/tests/signals.sh
+++ b/tests/signals.sh
@@ -40,8 +40,8 @@ cat > "$conf"<<EOF
;; the signal handler needs to send a message to
;; the process monitor and/or service registry.
#:start (make-forkexec-constructor '("sleep" "100"))
- #:stop (lambda (pid)
- (kill pid SIGKILL)
+ #:stop (lambda (process)
+ (kill (process-id process) SIGKILL)
(call-with-output-file "$stamp"
(lambda (port)
(display "stopped" port)))
diff --git a/tests/system-star.sh b/tests/system-star.sh
index 9260109..ca8f636 100755
--- a/tests/system-star.sh
+++ b/tests/system-star.sh
@@ -59,8 +59,9 @@ cat > "$conf" <<EOF
#:start (make-forkexec-constructor
(list "$SHELL" "-cex"
"[ ! -f $PWD/$stamp ] ; touch $PWD/$stamp ; sleep 60"))
- #:stop (lambda (pid)
- (and (zero? (system* "$(type -P kill)" (number->string pid)))
+ #:stop (lambda (process)
+ (and (zero? (system* "$(type -P kill)"
+ (number->string (process-id process))))
(begin
(delete-file "$stamp")
#f)))