1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
(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))))))
|
