shepherd-with-sock.scm (9670B)
1 (define-module (shepherd-with-sock) 2 #:use-module (ice-9 match) 3 #:use-module ((shepherd service) 4 #:select (handle-SIGCHLD read-pid-file)) 5 #:use-module ((shepherd support) 6 #:select (catch-system-error)) 7 #:use-module ((shepherd system) 8 #:select (max-file-descriptors)) 9 #:export (make-forkexec-constructor)) 10 11 12 (define default-service-directory (@@ (shepherd service) default-service-directory)) 13 (define default-environment-variables (@@ (shepherd service) default-environment-variables)) 14 (define %pid-file-timeout (@@ (shepherd service) %pid-file-timeout)) 15 16 17 (define (clean-up-file file) 18 (when file 19 (catch 'system-error 20 (lambda () 21 (delete-file file)) 22 (lambda args 23 (unless (= ENOENT (system-error-errno args)) 24 (apply throw args)))))) 25 26 27 (define (open-service-stdin stdin-socket) 28 (define (get-sock pf af . addr) 29 (let ((sock (socket pf SOCK_STREAM 0))) 30 (apply bind sock af addr) 31 (fileno sock))) 32 (match stdin-socket 33 (('unix sockpath) 34 (clean-up-file sockpath) 35 (get-sock PF_UNIX AF_UNIX sockpath)) 36 (('tcp addr port) 37 (get-sock PF_INET AF_INET (inet-pton AF_INET addr) port)) 38 (('tcp6 addr port) 39 (get-sock PF_INET6 AF_INET6 (inet-pton AF_INET6 addr) port)) 40 (#f 41 ;; Make sure file descriptor zero is used, so we don't end up reusing 42 ;; it for something unrelated, which can confuse some packages. 43 (open-fdes "/dev/null" O_RDONLY)))) 44 45 46 (define* (exec-command command 47 #:key 48 (user #f) 49 (group #f) 50 (log-file #f) 51 (directory (default-service-directory)) 52 (environment-variables (default-environment-variables)) 53 (stdin-socket #f)) 54 "Run COMMAND as the current process from DIRECTORY, and with 55 ENVIRONMENT-VARIABLES (a list of strings like \"PATH=/bin\".) File 56 descriptors 1 and 2 are kept as is or redirected to LOG-FILE if it's true, 57 whereas file descriptor 0 (standard input) points to /dev/null; all other file 58 descriptors are closed prior to yielding control to COMMAND. 59 60 By default, COMMAND is run as the current user. If the USER keyword 61 argument is present and not false, change to USER immediately before 62 invoking COMMAND. USER may be a string, indicating a user name, or a 63 number, indicating a user ID. Likewise, COMMAND will be run under the 64 current group, unless the GROUP keyword argument is present and not 65 false." 66 (match command 67 ((program args ...) 68 ;; Become the leader of a new session and session group. 69 ;; Programs such as 'mingetty' expect this. 70 (setsid) 71 72 (chdir directory) 73 (environ environment-variables) 74 75 ;; Close all the file descriptors except stdout and stderr. 76 (let ((max-fd (max-file-descriptors))) 77 ;; Redirect stdin to use /dev/null or stdin-socket 78 (catch-system-error (close-fdes 0)) 79 80 ;; Make sure file descriptor zero is always used, so we don't end up reusing 81 ;; it for something unrelated, which can confuse some packages. 82 (dup2 (open-service-stdin stdin-socket) 0) 83 84 (when log-file 85 (catch #t 86 (lambda () 87 ;; Redirect stout and stderr to use LOG-FILE. 88 (catch-system-error (close-fdes 1)) 89 (catch-system-error (close-fdes 2)) 90 (dup2 (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)) 1) 91 (dup2 1 2)) 92 (lambda (key . args) 93 (format (current-error-port) 94 "failed to open log-file ~s:~%" log-file) 95 (print-exception (current-error-port) #f key args) 96 (primitive-exit 1)))) 97 98 ;; setgid must be done *before* setuid, otherwise the user will 99 ;; likely no longer have permissions to setgid. 100 (when group 101 (catch #t 102 (lambda () 103 ;; Clear supplementary groups. 104 (setgroups #()) 105 (setgid (group:gid (getgr group)))) 106 (lambda (key . args) 107 (format (current-error-port) 108 "failed to change to group ~s:~%" group) 109 (print-exception (current-error-port) #f key args) 110 (primitive-exit 1)))) 111 112 (when user 113 (catch #t 114 (lambda () 115 (setuid (passwd:uid (getpw user)))) 116 (lambda (key . args) 117 (format (current-error-port) 118 "failed to change to user ~s:~%" user) 119 (print-exception (current-error-port) #f key args) 120 (primitive-exit 1)))) 121 122 ;; As the last action, close file descriptors. Doing it last makes 123 ;; "error in the finalization thread: Bad file descriptor" issues 124 ;; unlikely on 2.2. 125 (let loop ((i 3)) 126 (when (< i max-fd) 127 ;; First try to close any ports associated with file descriptor I. 128 ;; Otherwise the finalization thread might get around to closing 129 ;; those ports eventually, which will raise an EBADF exception (on 130 ;; 2.2), leading to messages like "error in the finalization 131 ;; thread: Bad file descriptor". 132 (for-each (lambda (port) 133 (catch-system-error (close-port port))) 134 (fdes->ports i)) 135 (catch-system-error (close-fdes i)) 136 (loop (+ i 1))))) 137 138 (catch 'system-error 139 (lambda () 140 (apply execlp program program args)) 141 (lambda args 142 (format (current-error-port) 143 "exec of ~s failed: ~a~%" 144 program (strerror (system-error-errno args))) 145 (primitive-exit 1)))))) 146 147 (define (ensure-sigchld-handler) 148 (unless (@@ (shepherd service) %sigchld-handler-installed?) 149 (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP) 150 (set! (@@ (shepherd service) %sigchld-handler-installed?) #t))) 151 152 (define* (fork+exec-command command 153 #:key 154 (user #f) 155 (group #f) 156 (log-file #f) 157 (directory (default-service-directory)) 158 (environment-variables 159 (default-environment-variables)) 160 (stdin-socket #f)) 161 "Spawn a process that executed COMMAND as per 'exec-command', and return 162 its PID." 163 (ensure-sigchld-handler) 164 ;; Install the SIGCHLD handler if this is the first fork+exec-command call 165 (let ((pid (primitive-fork))) 166 (if (zero? pid) 167 (exec-command command 168 #:user user 169 #:group group 170 #:log-file log-file 171 #:directory directory 172 #:environment-variables environment-variables 173 #:stdin-socket stdin-socket) 174 pid))) 175 176 177 178 (define make-forkexec-constructor 179 (let ((warn-deprecated-form 180 ;; Until 0.1, this procedure took a rest list. 181 (lambda () 182 (issue-deprecation-warning 183 "This 'make-forkexec-constructor' form is deprecated; use 184 (make-forkexec-constructor '(\"PROGRAM\" \"ARGS\"...).")))) 185 (case-lambda* 186 "Return a procedure that forks a child process, closes all file 187 descriptors except the standard output and standard error descriptors, sets 188 the current directory to @var{directory}, changes the environment to 189 @var{environment-variables} (using the @code{environ} procedure), sets the 190 current user to @var{user} and the current group to @var{group} unless they 191 are @code{#f}, and executes @var{command} (a list of strings.) The result of 192 the procedure will be the PID of the child process. 193 194 When @var{pid-file} is true, it must be the name of a PID file associated with 195 the process being launched; the return value is the PID read from that file, 196 once that file has been created. If @var{pid-file} does not show up in less 197 than @var{pid-file-timeout} seconds, the service is considered as failing to 198 start." 199 ((command #:key 200 (user #f) 201 (group #f) 202 (directory (default-service-directory)) 203 (environment-variables (default-environment-variables)) 204 (pid-file #f) 205 (pid-file-timeout %pid-file-timeout) 206 (log-file #f) 207 (stdin-socket #f)) 208 (let ((command (if (string? command) 209 (begin 210 (warn-deprecated-form) 211 (list command)) 212 command))) 213 (lambda args 214 (clean-up-file pid-file) 215 (clean-up-file log-file) 216 217 (let ((pid (fork+exec-command command 218 #:user user 219 #:group group 220 #:log-file log-file 221 #:directory directory 222 #:environment-variables 223 environment-variables 224 #:stdin-socket stdin-socket))) 225 (if pid-file 226 (match (read-pid-file pid-file 227 #:max-delay pid-file-timeout) 228 (#f 229 (catch-system-error (kill pid SIGTERM)) 230 #f) 231 ((? integer? pid) 232 pid)) 233 pid))))) 234 ((program . program-args) 235 ;; The old form, documented until 0.1 included. 236 (warn-deprecated-form) 237 (make-forkexec-constructor (cons program program-args))))))