(define-module (shepherd-with-sock) #:use-module (ice-9 match) #:use-module ((shepherd service) #:select (handle-SIGCHLD read-pid-file)) #:use-module ((shepherd support) #:select (catch-system-error)) #:use-module ((shepherd system) #:select (max-file-descriptors)) #:export (make-forkexec-constructor)) (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 (clean-up-file file) (when file (catch 'system-error (lambda () (delete-file file)) (lambda args (unless (= ENOENT (system-error-errno args)) (apply throw args)))))) (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) (clean-up-file 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 (ensure-sigchld-handler) (unless (@@ (shepherd service) %sigchld-handler-installed?) (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP) (set! (@@ (shepherd service) %sigchld-handler-installed?) #t))) (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." (ensure-sigchld-handler) ;; Install the SIGCHLD handler if this is the first fork+exec-command call (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 (clean-up-file pid-file) (clean-up-file 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))))))