From cd260ae65056b53749e7c03f2498a28af2525934 Mon Sep 17 00:00:00 2001 From: Ioannis Panagiotis Koutsidis Date: Tue, 10 Jul 2018 20:03:21 +0300 Subject: [PATCH] .socket units --- modules/shepherd.scm | 44 +++-- modules/shepherd/service.scm | 170 ++++++++++------- modules/shepherd/systemd.scm | 354 ++++++++++++++++++++++++----------- 3 files changed, 368 insertions(+), 200 deletions(-) diff --git a/modules/shepherd.scm b/modules/shepherd.scm index 5d97598..45fcb23 100644 --- a/modules/shepherd.scm +++ b/modules/shepherd.scm @@ -31,6 +31,7 @@ #:use-module (shepherd config) #:use-module (shepherd support) #:use-module (shepherd service) + #:use-module (shepherd systemd) #:use-module (shepherd system) #:use-module (shepherd runlevel) #:use-module (shepherd args) @@ -259,9 +260,18 @@ (setvbuf command-source _IOFBF 1024) (process-connection command-source)) (_ #f))) - (match (select (list sock) (list) (list) (if poll-services? 0.5 #f)) - (((sock) _ _) - (read-from sock)) + + (match (select (cons* sock unit-sockets-list) (list) (list) + (if poll-services? 0.5 #f)) + (((rsock _ ...) _ _) + (let* ((sockserv1 (find (lambda (x) + (eq? (slot-ref x 'running) rsock)) + (service-list))) + (sockserv (if sockserv1 (before sockserv1) #f)) + (res (if sockserv (car (lookup-services (string->symbol (car sockserv)))) #f))) + (if res + (start res (accept rsock)) + (read-from sock)))) (_ #f)) (when poll-services? diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm index 5b0d72d..ceba004 100644 --- a/modules/shepherd/service.scm +++ b/modules/shepherd/service.scm @@ -74,6 +74,7 @@ make-forkexec-constructor make-kill-destructor exec-command + exec-command2 fork+exec-command read-pid-file make-system-constructor @@ -102,7 +103,10 @@ action-runtime-error-key action-runtime-error-arguments - condition->sexp)) + condition->sexp + + before + service-list)) ;; Keep track of lazy initialization of SIGCHLD handler (define %sigchld-handler-installed? #f) @@ -161,16 +165,12 @@ respawned, shows that it has been respawned more than TIMES in SECONDS." (requires #:init-keyword #:requires #:init-value '() #:getter required-by) - ;; If `#t', then assume the `running' slot specifies a PID and - ;; respawn it if that process terminates. Otherwise `#f'. + ;; If not #f, then assume the `running' slot specifies a PID and + ;; respawn it if that process terminates. Otherwise it can be + ;; 'on-success, 'on-failure, 'on-abnormal, 'on-watchdog, 'on-abort, or 'always (respawn? #:init-keyword #:respawn? - #:init-value #f + #:init-value 'no #:getter respawn?) - ;; For the systemd restart values. Can be 'no (when respawn? is #f), - ;; 'on-success, 'on-failure, 'on-abnormal, 'on-watchdog, 'on-abort, or 'always - (respawn-systemd #:init-keyword #:respawn-systemd - #:init-value 'always - #:getter respawn-systemd) ;; The action to perform to start the service. This must be a ;; procedure and may take an arbitrary amount of arguments, but it ;; must be possible to call it without any argument. If the @@ -211,7 +211,11 @@ respawned, shows that it has been respawned more than TIMES in SECONDS." (stop-delay? #:init-keyword #:stop-delay? #:init-value #f) ;; The times of the last respawns, most recent first. - (last-respawns #:init-form '())) + (last-respawns #:init-form '()) + ;; if it is a socket unit file, it contains all services that depend on it + (before #:init-keyword #:before + #:init-value '() + #:getter before)) (define (service? obj) "Return true if OBJ is a service." @@ -331,7 +335,7 @@ wire." ;; Start the service itself. Asyncs are blocked so that if ;; the newly-started process dies immediately, the SIGCHLD ;; handler is invoked later, once we have set the 'running' - ;; field. + ;; field . (slot-set! obj 'running (catch #t (lambda () (apply (slot-ref obj 'start) @@ -693,25 +697,17 @@ otherwise return the number that was read (a PID)." (loop))) (apply throw args))))))) -(define* (exec-command command - #:key - (user #f) - (group #f) - (log-file #f) - (directory (default-service-directory)) - (environment-variables (default-environment-variables))) - "Run COMMAND as the current process from DIRECTORY, and with -ENVIRONMENT-VARIABLES (a list of strings like \"PATH=/bin\".) File -descriptors 1 and 2 are kept as is or redirected to LOG-FILE if it's true, -whereas file descriptor 0 (standard input) points to /dev/null; all other file -descriptors are closed prior to yielding control to COMMAND. - -By default, COMMAND is run as the current user. If the USER keyword -argument is present and not false, change to USER immediately before -invoking COMMAND. USER may be a string, indicating a user name, or a -number, indicating a user ID. Likewise, COMMAND will be run under the -current group, unless the GROUP keyword argument is present and not -false." +(define* (exec-command2 command + #:key + (user #f) + (group #f) + (stdin #f) + (stderr #f) + (stdout #f) + (directory (default-service-directory)) + (rdir "/") + (environment-variables (default-environment-variables))) + "Like exec-command but extended" (match command ((program args ...) ;; Become the leader of a new session and session group. @@ -719,30 +715,23 @@ false." (setsid) (chdir directory) + (chroot rdir) (environ environment-variables) - ;; Close all the file descriptors except stdout and stderr. - (let ((max-fd (max-file-descriptors))) - + (unless stdin ;; Redirect stdin to use /dev/null (catch-system-error (close-fdes 0)) ;; Make sure file descriptor zero is used, so we don't end up reusing ;; it for something unrelated, which can confuse some packages. - (dup2 (open-fdes "/dev/null" O_RDONLY) 0) - - (when log-file - (catch #t - (lambda () - ;; Redirect stout and stderr to use LOG-FILE. - (catch-system-error (close-fdes 1)) - (catch-system-error (close-fdes 2)) - (dup2 (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)) 1) - (dup2 1 2)) - (lambda (key . args) - (format (current-error-port) - "failed to open log-file ~s:~%" log-file) - (print-exception (current-error-port) #f key args) - (primitive-exit 1)))) + (dup2 (open-fdes "/dev/null" O_RDONLY) 0)) + + (when stdin + (dup2 stdin 0)) + + (when stdout + (dup2 stdout 1)) + (when stderr + (dup2 stderr 2)) ;; setgid must be done *before* setuid, otherwise the user will ;; likely no longer have permissions to setgid. @@ -784,14 +773,54 @@ false." (catch-system-error (close-fdes i)) (loop (+ i 1))))) - (catch 'system-error - (lambda () - (apply execlp program program args)) - (lambda args - (format (current-error-port) - "exec of ~s failed: ~a~%" - program (strerror (system-error-errno args))) - (primitive-exit 1)))))) + (catch 'system-error + (lambda () + (apply execlp program program args)) + (lambda args + (format (current-error-port) + "exec of ~s failed: ~a~%" + program (strerror (system-error-errno args))) + (primitive-exit 1))))) + +(define* (exec-command command + #:key + (user #f) + (group #f) + (log-file #f) + (directory (default-service-directory)) + (environment-variables (default-environment-variables))) + "Run COMMAND as the current process from DIRECTORY, and with +ENVIRONMENT-VARIABLES (a list of strings like \"PATH=/bin\".) File +descriptors 1 and 2 are kept as is or redirected to LOG-FILE if it's true, +whereas file descriptor 0 (standard input) points to /dev/null; all other file +descriptors are closed prior to yielding control to COMMAND. + +By default, COMMAND is run as the current user. If the USER keyword +argument is present and not false, change to USER immediately before +invoking COMMAND. USER may be a string, indicating a user name, or a +number, indicating a user ID. Likewise, COMMAND will be run under the +current group, unless the GROUP keyword argument is present and not +false." + (let ((fd (if log-file + (catch #t + (lambda () + ;; Redirect stout and stderr to use LOG-FILE. + (catch-system-error (close-fdes 1)) + (catch-system-error (close-fdes 2)) + (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND))) + (lambda (key . args) + (format (current-error-port) + "failed to open log-file ~s:~%" log-file) + (print-exception (current-error-port) #f key args) + (primitive-exit 1))) + #f))) + (exec-command command + #:user user + #:group group + #:stdout fd + #:stderr fd + #:directory directory + #:environment-variables environment-variables))) (define* (fork+exec-command command #:key @@ -1031,20 +1060,20 @@ then disable it." (not (respawn-limit-hit? (slot-ref serv 'last-respawns) (car respawn-limit) (cdr respawn-limit)))) - (let* ([e (status:exit-val status)] - [t (status:term-sig status)] - [r (respawn-systemd serv)] - [clean (or (zero? e) - (equal? t SIGHUP) - (equal? t SIGINT) - (equal? t SIGTERM) - (equal? t SIGPIPE))]) - (if (or (equal? r 'always) - (equal? r 'on-watchdog) ;; not implemented yet - (and (equal? r 'on-success) clean) - (and (equal? r 'on-abnormal) (not clean) (equal? e #f)) - (and (equal? r 'on-failure) (not clean)) - (and (equal? r 'on-abort) (equal? t SIGABRT))) + (let* ((e (status:exit-val status)) + (t (status:term-sig status)) + (r (respawn? serv)) + (clean (or (eq? e 0) + (eq? t SIGHUP) + (eq? t SIGINT) + (eq? t SIGTERM) + (eq? t SIGPIPE)))) + (if (or (eq? r 'always) + (eq? r 'on-watchdog) ;; not implemented yet + (and (eq? r 'on-success) clean) + (and (eq? r 'on-abnormal) (not clean) (equal? e #f)) + (and (eq? r 'on-failure) (not clean)) + (and (eq? r 'on-abort) (= t SIGABRT))) (if (not (slot-ref serv 'waiting-for-termination?)) (begin ;; Everything is okay, start it. @@ -1075,7 +1104,6 @@ then disable it." ;; Sanity-checks first. (assert (list-of-symbols? (provided-by new))) (assert (list-of-symbols? (required-by new))) - (assert (boolean? (respawn? new))) ;; Canonical name actually must be canonical. (FIXME: This test ;; is incomplete, since we may add a service later that makes it ;; non-cannonical.) diff --git a/modules/shepherd/systemd.scm b/modules/shepherd/systemd.scm index 77679fa..1dee888 100644 --- a/modules/shepherd/systemd.scm +++ b/modules/shepherd/systemd.scm @@ -17,127 +17,257 @@ ;; along with the GNU Shepherd. If not, see . (define-module (shepherd systemd) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 textual-ports) #:use-module (oop goops) #:use-module (shepherd service) - #:export (make-systemd-service)) + #:export (read-unit-file + unit-files->services + unit-sockets-list)) -;; Change this -(define unitdir "/systemd/") +(define unit-sockets-list '()) -;; Implements a state machine to parse the ini-like systemd unit files -(define (unit-parse s) - (letrec ([unit-parse (lambda (s state key value kv) - (match (list s state) - [((or (#\newline _ ...) - ()) 'keypart) - (error "Key " (list->string key) " is missing its value")] - [(() (or 'valuepart 'firstchar 'ignoreline)) - kv] - [lst (let ([rest (cdar lst)]) - (match (list (caar lst) state) - [((or #\; - #\[) 'firstchar) - (unit-parse rest - 'ignoreline - '() - '() - kv)] - [(#\newline (or 'firstchar - 'ignoreline)) - (unit-parse rest - 'firstchar - '() - '() - kv)] - [(#\= 'keypart) - (unit-parse rest - 'valuepart - key - '() - kv)] - [(#\newline 'valuepart) - (unit-parse rest - 'firstchar - '() - '() - `((,(list->string key) - . ,(list->string value)) - . ,kv))] - [(_ 'ignoreline) - (unit-parse rest - 'ignoreline - '() - '() - kv)] - [(c 'valuepart) - (unit-parse rest - 'valuepart - key - (append value `(,c)) - kv)] - [(c (or 'keypart 'firstchar)) - (unit-parse rest - 'keypart - (append key `(,c)) - '() - kv)]))]))]) - (unit-parse (string->list s) 'firstchar '() '() '()))) +(define (read-unit-file file) + "Implements a state machine to parse the ini-like systemd unit files." + (define (unit-parse file state key value kv) + (define c (read-char file)) + (match (list (if (eof-object? c) #f c) state) + (((or #f #\newline) 'keypart) + (error "Key " (list->string key) " is missing its value")) + ((#f (or 'valuepart 'firstchar 'ignoreline)) + kv) + (((or #\; #\[) 'firstchar) + (unit-parse file + 'ignoreline + '() + '() + kv)) + ((#\newline (or 'firstchar 'ignoreline)) + (unit-parse file + 'firstchar + '() + '() + kv)) + ((#\= 'keypart) + (unit-parse file + 'valuepart + key + '() + kv)) + ((#\newline 'valuepart) + (unit-parse file + 'firstchar + '() + '() + `((,(list->string key) + . ,(list->string value)) + . ,kv))) + ((_ 'ignoreline) + (unit-parse file + 'ignoreline + '() + '() + kv)) + ((c 'valuepart) + (unit-parse file + 'valuepart + key + (append value `(,c)) + kv)) + ((c (or 'keypart 'firstchar)) + (unit-parse file + 'keypart + (append key `(,c)) + '() + kv)))) + (unit-parse file 'firstchar '() '() '())) -(define (unit-parse-file path) - (let* ([in (open-input-file path)] - [out (unit-parse (get-string-all in))]) - (close-port in) - out)) +(define (dassoc alst key default) + "assoc-ref with a default value" + (or (assoc-ref alst key) default)) -;; like assoc but uses a coninuation for failure and success -(define (kassoc key alst failure success) - (let ((res (assoc key alst))) - (if (equal? res #f) - failure - (success (cdr res))))) +(define (make-socket family addr port backlog) + (define sock (socket family SOCK_STREAM 0)) + (fcntl sock F_SETFD FD_CLOEXEC) + (cond ((= family PF_UNIX) (bind sock AF_UNIX addr)) + ((= family PF_INET) (bind sock AF_INET (inet-pton AF_INET addr) port)) + ((= family PF_INET6) (bind sock AF_INET6 (inet-pton AF_INET6 addr) port)) + (#t (error "Unknown protocol"))) + (fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL))) + (listen sock backlog) + sock) -;; like assoc but 1: allows the use of a default value on failure -;; and 2: returns just the value instead of (cons key value) -(define (dassoc key alst default) - (kassoc key alst default (lambda (x) x))) +(define %sigchld-handler-installed? #f) -(define (make-systemd-service name) - (let* ([alst (unit-parse-file (string-append unitdir name))] - [busname (dassoc "BusName" alst #f)] - [execstart (dassoc "ExecStart" alst #f)] - [type (dassoc "Type" alst (if (equal? execstart #f) - "oneshot" - (if (equal? busname #f) - "simple" - "dbus")))] - [restart (string->symbol (dassoc "Restart" alst "no"))] - [user (dassoc "User" alst #f)] - [group (dassoc "Group" alst #f)] - [rootdir (dassoc "RootDirectory" alst "/")] ;; not currently used - [workdir (dassoc "WorkingDirectory" alst rootdir)] - [command execstart]) +;; TODO: deduplicate +(define* (fork+exec-command2 command + #:key + (user #f) + (group #f) + (stdin #f) + (stdout #f) + (stderr #f) + (directory (default-service-directory)) + (rdir "/") + (environment-variables (environ))) + "Spawn a process that executed COMMAND as per 'exec-command', and return +its PID." + ;; Install the SIGCHLD handler if this is the first fork+exec-command call + (unless %sigchld-handler-installed? + (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP) + (set! %sigchld-handler-installed? #t)) + (let ((pid (primitive-fork))) + (if (zero? pid) + (exec-command2 command + #:user user + #:group group + #:stdin stdin + #:stdout stdout + #:stderr stderr + #:directory directory + #:rdir rdir + #:environment-variables environment-variables) + pid))) - (make - #:docstring (dassoc "Description" alst "") - #:provides `(,(string->symbol name)) - #:requires (let* ([req (string-split (dassoc "Requires" alst "") #\space)] - [req2 (if (equal? req '("")) - '() - (map string->symbol req))]) - (if (equal? type "dbus") - (append req2 'dbus.service) - req2)) - #:respawn-systemd restart - #:respawn? #t - #:start (cond [(and (equal? type "simple") (not (equal? command #f))) - (make-forkexec-constructor (list "/bin/sh" "-c" command) - #:user user - #:group group - #:directory workdir)] - [#t '()]) ; TODO: non-simple services (which exit) - ; should not use make-forkexec-constructor - #:stop (make-kill-destructor #:timeout 60)))) +;; TODO: deduplicate +(define* (make-forkexec-constructor-sock command + #:key + (user #f) + (group #f) + (directory (default-service-directory)) + (rdir "/") + (environment-variables (environ)) + (pid-file #f) + (pid-file-timeout 5)) + "See make-forkexec-constructor" + (lambda (sock) + (define (clean-up file) + (when file + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))))) -(register-services (make-systemd-service "test.service")) + (clean-up pid-file) + + (let* ((pid (fork+exec-command2 command + #:user user + #:group group + #:stdin sock + #:stdout sock + #:directory directory + #:rdir rdir + #:environment-variables + environment-variables))) + (if pid-file + (match (read-pid-file pid-file + #:max-delay pid-file-timeout) + (#f + (catch-system-error (kill pid SIGTERM)) + #f) + ((? integer? pid) + pid)) + pid)))) + +;; O(n^2) +(define (unit-files->services ufiles-orig) + (define (inner ufiles return) + (match ufiles + (() return) + (((fullname basename 'service alst) rest ...) + (let* ((dassoc (lambda (name val) (dassoc alst name val))) + (busname (dassoc "BusName" #f)) + (execstart (dassoc "ExecStart" #f)) + (execstartpre (dassoc "ExecStartPre" #f)) ;; TODO + (execstartpost (dassoc "ExecStartPost" #f)) ;; TODO + (execstop (dassoc "ExecStop" #f)) + (execstoppost (dassoc "ExecStopPost" #f)) ;; TODO + (execreload (dassoc "ExecReload" #f)) ;; TODO + (type (dassoc "Type" (if (equal? execstart #f) + "oneshot" + (if (equal? busname #f) + "simple" + "dbus")))) + (restart (let ((res (dassoc "Restart" "no"))) + (if (eq? res #f) + #f + (string->symbol res)))) + (user (dassoc "User" #f)) + (group (dassoc "Group" #f)) + (rootdir (dassoc "RootDirectory" "/")) ;; TODO + (workdir (dassoc "WorkingDirectory" rootdir)) + (env (dassoc "Environment" #f))) ;; TODO + + (let ((serv (make + #:docstring (dassoc "Description" "") + #:provides `(,(string->symbol fullname)) + #:requires (let* ((req (string-split (dassoc "Requires" + "") + #\space)) + (req2 (if (equal? req '("")) + '() + (map string->symbol req)))) + (if (equal? type "dbus") + (append req2 'dbus.service) + req2)) + #:respawn? restart + #:start (if (find (lambda (x) + (match x + ((_ basename2 'socket _) + (eq? basename basename2)) + (_ #f))) ufiles-orig) + (make-forkexec-constructor-sock + (list "/bin/sh" "-c" execstart) + #:user user + #:group group + #:directory workdir + #:rdir rootdir) + (cond [(and (equal? type "simple") + (not (equal? execstart #f))) + (make-forkexec-constructor + (list "/bin/sh" "-c" execstart) + #:user user + #:group group + #:directory workdir)] + [#t '()])) ;; TODO: nonsimple + #:stop (make-kill-destructor #:timeout 60)))) + (inner rest (cons serv return))))) + (((fullname basename 'socket alst) rest ...) + (let* ((dassoc (lambda (name val) (dassoc alst name val))) + (backlog (dassoc "Backlog" 128)) + (listens (string-split (dassoc "ListenStream" #f) #\:)) + (port (string->number (cadr listens))) + (addr (car listens))) + + (let ((serv (make + #:docstring (dassoc "Description" "") + #:provides `(,(string->symbol fullname)) + #:start (lambda args + (let ((sock (make-socket PF_INET addr port backlog))) + (set! unit-sockets-list + (cons sock unit-sockets-list)) + sock)) + #:stop (lambda (running) (begin (delete running + unit-sockets-list) + (close running) + #f)) + #:before (find (lambda (x) + (match x + ((_ basename2 'service _) + (eq? basename basename2)) + (_ #f))) ufiles-orig)))) + (inner rest (cons serv return))))))) + (inner ufiles-orig (list))) -- 2.18.0