From c51c406adc9cd5b3c56aa709a688ff72a35bb7ed Mon Sep 17 00:00:00 2001 From: Florian Dold Date: Tue, 4 Dec 2018 11:24:50 +0100 Subject: shepherd socket activation --- guix/config.scm | 50 ++++++++-- guix/shepherd-with-sock.scm | 225 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 265 insertions(+), 10 deletions(-) create mode 100644 guix/shepherd-with-sock.scm (limited to 'guix') diff --git a/guix/config.scm b/guix/config.scm index 6e9982e..e2cf6ba 100644 --- a/guix/config.scm +++ b/guix/config.scm @@ -21,6 +21,7 @@ (use-modules (srfi srfi-1) + (ice-9 match) (gnu) (guix) (guix utils) @@ -29,7 +30,7 @@ (taler-helpers)) (use-system-modules nss) -(use-service-modules networking ssh version-control cgit databases admin web) +(use-service-modules networking ssh version-control cgit databases admin web shepherd) (use-package-modules base bash shells web tls) ;;; Commentary: @@ -55,19 +56,48 @@ (group my-fcgiwrap-configuration-group (default "fcgiwrap"))) +(define (parse-fcgiwrap-socket s) + (cond + ((string-prefix? "unix:" s) + (list 'unix (substring s 5))) + ((string-prefix? "tcp:" s) + (match (string-match "^tcp:([.0-9]+):([0-9]+)$" s) + ((? regexp-match? m) + (list + 'tcp + (match:substring m 1) + (string->number (match:substring m 2)))) + (_ (error "invalid tcp socket address")))) + ((string-prefix? "tcp6:" s) + (match (string-match "^tcp6:\\[(.*)\\]:([0-9]+)$" s) + ((? regexp-match? m) + (list + 'tcp6 + (match:substring m 1) + (string->number (match:substring m 2)))) + (_ (error "invalid tcp6 socket address")))) + (else (error "unrecognized socket protocol")))) + (define my-fcgiwrap-shepherd-service (match-lambda (($ package socket user group) - (list (shepherd-service - (provision '(fcgiwrap)) - (documentation "Run the fcgiwrap daemon.") - (requirement '(networking)) - (start #~(make-forkexec-constructor - '(#$(file-append package "/sbin/fcgiwrap") - "-s" #$socket) - #:user #$user #:group #$group)) - (stop #~(make-kill-destructor))))))) + (let ((parsed-socket (parse-fcgiwrap-socket socket))) + (list + (shepherd-service + (provision '(fcgiwrap)) + (documentation "Run the fcgiwrap daemon.") + (requirement '(networking)) + (start (with-imported-modules + '((shepherd-with-sock)) + #~(begin + (use-modules ((shepherd-with-sock) #:prefix my:)) + (my:make-forkexec-constructor + '(#$(file-append package "/sbin/fcgiwrap")) + #:user #$user + #:group #$group + #:stdin-socket #$parsed-socket)))) + (stop #~(make-kill-destructor)))))))) (define my-fcgiwrap-accounts diff --git a/guix/shepherd-with-sock.scm b/guix/shepherd-with-sock.scm new file mode 100644 index 0000000..7a43c66 --- /dev/null +++ b/guix/shepherd-with-sock.scm @@ -0,0 +1,225 @@ +(define-module (shepherd-with-sock) + #:use-module ((shepherd service) + #:select ())) + + +(define default-service-directory (@@ (shepherd service) default-service-directory)) +(define default-environment-variables (@@ (shepherd service) default-environment-variables)) +(define %pid-file-timeout (@@ (shepherd service) %pid-file-timeout)) + + +(define (open-service-stdin stdin-socket) + (define (get-sock pf af . addr) + (let ((sock (socket pf SOCK_STREAM 0))) + (apply bind sock af addr) + (fileno sock))) + (match stdin-socket + (('unix sockpath) + (get-sock PF_UNIX AF_UNIX sockpath) + (('tcp addr port) + (get-sock PF_INET AF_INET (inet-pton AF_INET addr) port)) + (('tcp6 addr port) + (get-sock PF_INET6 AF_INET6 (inet-pton AF_INET6 addr) port)) + (#f + ;; Make sure file descriptor zero is used, so we don't end up reusing + ;; it for something unrelated, which can confuse some packages. + (open-fdes "/dev/null" O_RDONLY)))) + + +(define* (exec-command command + #:key + (user #f) + (group #f) + (log-file #f) + (directory (default-service-directory)) + (environment-variables (default-environment-variables)) + (stdin-socket #f)) + "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." + (match command + ((program args ...) + ;; Become the leader of a new session and session group. + ;; Programs such as 'mingetty' expect this. + (setsid) + + (chdir directory) + (environ environment-variables) + + ;; Close all the file descriptors except stdout and stderr. + (let ((max-fd (max-file-descriptors))) + ;; Redirect stdin to use /dev/null or stdin-socket + (catch-system-error (close-fdes 0)) + + ;; Make sure file descriptor zero is always used, so we don't end up reusing + ;; it for something unrelated, which can confuse some packages. + (dup2 (open-service-stdin stdin-socket) 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)))) + + ;; setgid must be done *before* setuid, otherwise the user will + ;; likely no longer have permissions to setgid. + (when group + (catch #t + (lambda () + ;; Clear supplementary groups. + (setgroups #()) + (setgid (group:gid (getgr group)))) + (lambda (key . args) + (format (current-error-port) + "failed to change to group ~s:~%" group) + (print-exception (current-error-port) #f key args) + (primitive-exit 1)))) + + (when user + (catch #t + (lambda () + (setuid (passwd:uid (getpw user)))) + (lambda (key . args) + (format (current-error-port) + "failed to change to user ~s:~%" user) + (print-exception (current-error-port) #f key args) + (primitive-exit 1)))) + + ;; As the last action, close file descriptors. Doing it last makes + ;; "error in the finalization thread: Bad file descriptor" issues + ;; unlikely on 2.2. + (let loop ((i 3)) + (when (< i max-fd) + ;; First try to close any ports associated with file descriptor I. + ;; Otherwise the finalization thread might get around to closing + ;; those ports eventually, which will raise an EBADF exception (on + ;; 2.2), leading to messages like "error in the finalization + ;; thread: Bad file descriptor". + (for-each (lambda (port) + (catch-system-error (close-port port))) + (fdes->ports i)) + (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)))))) + + +(define* (fork+exec-command command + #:key + (user #f) + (group #f) + (log-file #f) + (directory (default-service-directory)) + (environment-variables + (default-environment-variables)) + (stdin-socket #f)) + "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-command command + #:user user + #:group group + #:log-file log-file + #:directory directory + #:environment-variables environment-variables + #:stdin-socket stdin-socket) + pid))) + +(define make-forkexec-constructor + (let ((warn-deprecated-form + ;; Until 0.1, this procedure took a rest list. + (lambda () + (issue-deprecation-warning + "This 'make-forkexec-constructor' form is deprecated; use + (make-forkexec-constructor '(\"PROGRAM\" \"ARGS\"...).")))) + (case-lambda* + "Return a procedure that forks a child process, closes all file +descriptors except the standard output and standard error descriptors, sets +the current directory to @var{directory}, changes the environment to +@var{environment-variables} (using the @code{environ} procedure), sets the +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.) The result of +the procedure will be the PID of 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, +once that file has been created. If @var{pid-file} does not show up in less +than @var{pid-file-timeout} seconds, the service is considered as failing to +start." + ((command #:key + (user #f) + (group #f) + (directory (default-service-directory)) + (environment-variables (default-environment-variables)) + (pid-file #f) + (pid-file-timeout %pid-file-timeout) + (log-file #f) + (stdin-socket #f)) + (let ((command (if (string? command) + (begin + (warn-deprecated-form) + (list command)) + command))) + (lambda args + (define (clean-up file) + (when file + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))))) + + (clean-up pid-file) + (clean-up log-file) + + (let ((pid (fork+exec-command command + #:user user + #:group group + #:log-file log-file + #:directory directory + #:environment-variables + environment-variables + #:stdin-socket stdin-socket))) + (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))))) + ((program . program-args) + ;; The old form, documented until 0.1 included. + (warn-deprecated-form) + (make-forkexec-constructor (cons program program-args)))))) -- cgit v1.2.3