1 | ;; |
---|
2 | ;; Spiffy the web server |
---|
3 | ;; |
---|
4 | ; Copyright (c) 2007-2009, Peter Bex |
---|
5 | ; Copyright (c) 2000-2005, Felix L. Winkelmann |
---|
6 | ; All rights reserved. |
---|
7 | ; |
---|
8 | ; Redistribution and use in source and binary forms, with or without |
---|
9 | ; modification, are permitted provided that the following conditions |
---|
10 | ; are met: |
---|
11 | ; |
---|
12 | ; 1. Redistributions of source code must retain the above copyright |
---|
13 | ; notice, this list of conditions and the following disclaimer. |
---|
14 | ; 2. Redistributions in binary form must reproduce the above copyright |
---|
15 | ; notice, this list of conditions and the following disclaimer in the |
---|
16 | ; documentation and/or other materials provided with the distribution. |
---|
17 | ; 3. Neither the name of the author nor the names of its |
---|
18 | ; contributors may be used to endorse or promote products derived |
---|
19 | ; from this software without specific prior written permission. |
---|
20 | ; |
---|
21 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
---|
22 | ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
---|
23 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS |
---|
24 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE |
---|
25 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, |
---|
26 | ; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES |
---|
27 | ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
28 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) |
---|
29 | ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, |
---|
30 | ; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) |
---|
31 | ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED |
---|
32 | ; OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
33 | ; |
---|
34 | ; Please report bugs, suggestions and ideas to the Chicken Trac |
---|
35 | ; ticket tracking system (assign tickets to user 'sjamaan'): |
---|
36 | ; http://trac.callcc.org |
---|
37 | |
---|
38 | (provide 'spiffy) |
---|
39 | |
---|
40 | (module spiffy |
---|
41 | (start-server with-headers send-status send-static-file log-to |
---|
42 | write-logged-response build-error-message |
---|
43 | current-request remote-address local-address |
---|
44 | current-response current-file current-pathinfo |
---|
45 | server-software root-path server-port server-ssl-context server-root-uri |
---|
46 | index-files mime-type-map default-mime-type file-extension-handlers |
---|
47 | default-host vhost-map access-log error-log debug-log |
---|
48 | spiffy-user spiffy-group access-file max-connections |
---|
49 | handle-file handle-directory handle-not-found handle-exception |
---|
50 | handle-access-logging restart-request htmlize) |
---|
51 | |
---|
52 | (import chicken scheme extras ports files data-structures) |
---|
53 | (require-extension srfi-1 srfi-13 srfi-18 tcp regex posix |
---|
54 | openssl intarweb uri-common sendfile matchable) |
---|
55 | |
---|
56 | (define version 4) |
---|
57 | (define release 0) |
---|
58 | |
---|
59 | ;;; Request processing information |
---|
60 | (define current-request (make-parameter #f)) |
---|
61 | (define current-response (make-parameter #f)) |
---|
62 | (define current-file (make-parameter #f)) |
---|
63 | (define current-pathinfo (make-parameter #f)) |
---|
64 | (define local-address (make-parameter #f)) |
---|
65 | (define remote-address (make-parameter #f)) |
---|
66 | |
---|
67 | ;;; Configuration |
---|
68 | (define server-software (make-parameter `(("Spiffy" |
---|
69 | ,(conc version "." release) |
---|
70 | ,(conc "Running on Chicken " |
---|
71 | (chicken-version)))))) |
---|
72 | (define root-path (make-parameter "./web")) |
---|
73 | (define server-port (make-parameter 8080)) |
---|
74 | (define server-ssl-context (make-parameter #f)) |
---|
75 | (define index-files (make-parameter '("index.html" "index.xhtml"))) |
---|
76 | (define mime-type-map |
---|
77 | (make-parameter |
---|
78 | '(("xml" . text/xml) |
---|
79 | ("html" . text/html) |
---|
80 | ("xhtml" . text/xhtml+xml) |
---|
81 | ("js" . text/javascript) |
---|
82 | ("pdf" . application/pdf) |
---|
83 | ("css" . text/css) |
---|
84 | ("png" . image/png) |
---|
85 | ("ico" . image/x-icon) |
---|
86 | ("gif" . image/gif) |
---|
87 | ("jpeg" . image/jpeg) |
---|
88 | ("jpg" . image/jpeg) |
---|
89 | ("svg" . image/svg+xml) |
---|
90 | ("bmp" . image/bmp) |
---|
91 | ("txt" . text/plain)))) |
---|
92 | (define default-mime-type (make-parameter 'application/octet-stream)) |
---|
93 | (define file-extension-handlers (make-parameter '())) |
---|
94 | (define default-host (make-parameter "localhost")) ;; XXX Can we do without? |
---|
95 | (define vhost-map (make-parameter `((".*" . ,(lambda (cont) (cont)))))) |
---|
96 | (define access-log (make-parameter #f)) |
---|
97 | (define error-log (make-parameter (current-error-port))) |
---|
98 | (define debug-log (make-parameter #f)) |
---|
99 | (define spiffy-user (make-parameter #f)) |
---|
100 | (define spiffy-group (make-parameter #f)) |
---|
101 | (define access-file (make-parameter #f)) |
---|
102 | (define max-connections (make-parameter 1024)) |
---|
103 | |
---|
104 | ;;; Custom handlers |
---|
105 | (define handle-directory |
---|
106 | (make-parameter |
---|
107 | (lambda (path) |
---|
108 | (send-status 403 "Forbidden")))) |
---|
109 | (define handle-file |
---|
110 | (make-parameter |
---|
111 | (lambda (path) |
---|
112 | (let* ((ext (pathname-extension path)) |
---|
113 | (handler (alist-ref ext (file-extension-handlers) |
---|
114 | string-ci=? send-static-file))) |
---|
115 | (handler path))))) |
---|
116 | (define handle-not-found |
---|
117 | (make-parameter |
---|
118 | (lambda (path) |
---|
119 | (send-status 404 "Not found" |
---|
120 | "<p>The resource you requested could not be found</p>")))) |
---|
121 | (define handle-exception |
---|
122 | (make-parameter |
---|
123 | (lambda (exn chain) |
---|
124 | (log-to (error-log) "~A" (build-error-message exn chain #t)) |
---|
125 | (send-status 500 "Internal server error")))) |
---|
126 | |
---|
127 | ;; This is very powerful, but it also means people need to write quite |
---|
128 | ;; a bit of code to change the line slightly. In this respect Apache-style |
---|
129 | ;; log format strings could be better... |
---|
130 | (define handle-access-logging |
---|
131 | (make-parameter |
---|
132 | (lambda () |
---|
133 | (log-to (access-log) |
---|
134 | "~A [~A] \"~A ~A HTTP/~A.~A\" ~A" |
---|
135 | (remote-address) |
---|
136 | (seconds->string (current-seconds)) |
---|
137 | (request-method (current-request)) |
---|
138 | (uri->string (request-uri (current-request))) |
---|
139 | (request-major (current-request)) |
---|
140 | (request-minor (current-request)) |
---|
141 | (let ((product (header-contents 'user-agent |
---|
142 | (request-headers (current-request))))) |
---|
143 | (if product |
---|
144 | (product-unparser 'user-agent product) |
---|
145 | "**Unknown product**")))))) |
---|
146 | |
---|
147 | ;;;; End of configuration parameters |
---|
148 | |
---|
149 | (define (with-output-to-log log thunk) |
---|
150 | (when log |
---|
151 | (if (output-port? log) |
---|
152 | (with-output-to-port log thunk) |
---|
153 | (with-output-to-file log thunk append:)))) |
---|
154 | |
---|
155 | (define (log-to log fmt . rest) |
---|
156 | (with-output-to-log log |
---|
157 | (lambda () |
---|
158 | (apply printf fmt rest) |
---|
159 | (newline)))) |
---|
160 | |
---|
161 | (define build-error-message |
---|
162 | (let* ((cpa condition-property-accessor) |
---|
163 | (exn-message (cpa 'exn 'message "(no message)")) |
---|
164 | (exn-location (cpa 'exn 'location "(unknown location)")) |
---|
165 | (exn-arguments (cpa 'exn 'arguments '())) |
---|
166 | (exn? (condition-predicate 'exn))) |
---|
167 | (lambda (exn chain #!optional raw-output) |
---|
168 | (with-output-to-string |
---|
169 | (lambda () |
---|
170 | (if (exn? exn) |
---|
171 | (begin |
---|
172 | (unless raw-output (display "<h2>")) |
---|
173 | (display "Error:") |
---|
174 | (and-let* ((loc (exn-location exn))) |
---|
175 | (if raw-output |
---|
176 | (printf " (~A)" (->string loc)) |
---|
177 | (printf " (<em>~A</em>)" (htmlize (->string loc))))) |
---|
178 | (if raw-output |
---|
179 | (printf "\n~A\n" (exn-message exn)) |
---|
180 | (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn)))) |
---|
181 | (unless (null? (exn-arguments exn)) |
---|
182 | (unless raw-output (printf "<ul>")) |
---|
183 | (for-each |
---|
184 | (lambda (a) |
---|
185 | (##sys#with-print-length-limit |
---|
186 | 120 |
---|
187 | (lambda () |
---|
188 | (if raw-output |
---|
189 | (print (->string a)) |
---|
190 | (printf "<li>~A</li>" |
---|
191 | (htmlize (->string a))))))) |
---|
192 | (exn-arguments exn)) |
---|
193 | (unless raw-output |
---|
194 | (printf "</ul>"))) |
---|
195 | (if raw-output |
---|
196 | (print chain) |
---|
197 | (printf "<pre>~a</pre>" (htmlize chain)))) |
---|
198 | (begin |
---|
199 | (##sys#with-print-length-limit |
---|
200 | 120 |
---|
201 | (lambda () |
---|
202 | (if raw-output |
---|
203 | (printf "Uncaught exception:\n~S\n" exn) |
---|
204 | (printf "<h2>Uncaught exception:</h2>\n~S\n" exn))))))))))) |
---|
205 | |
---|
206 | (define (extension->mime-type ext) |
---|
207 | (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type))) |
---|
208 | |
---|
209 | (define handle-another-request? (make-parameter #f)) ;; Internal parameter |
---|
210 | |
---|
211 | (define (write-logged-response) |
---|
212 | ((handle-access-logging)) |
---|
213 | (handle-another-request? (and (keep-alive? (current-request)) |
---|
214 | (keep-alive? (current-response)))) |
---|
215 | (write-response (current-response))) |
---|
216 | |
---|
217 | ;; A simple utility procedure to render a status code with message |
---|
218 | (define (send-status code reason #!optional (text "")) |
---|
219 | (let* ((htmlized-reason (htmlize reason)) |
---|
220 | (output |
---|
221 | (conc "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>\n" |
---|
222 | "<!DOCTYPE html\n" |
---|
223 | " PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" |
---|
224 | " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" |
---|
225 | "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n" |
---|
226 | " xml:lang=\"en\" lang=\"en\">\n" |
---|
227 | " <head>\n" |
---|
228 | " <title>" code " - " htmlized-reason "</title>\n" |
---|
229 | " </head>\n" |
---|
230 | " <body>\n" |
---|
231 | " <h1>" code " - " htmlized-reason "</h1>\n" |
---|
232 | text "\n" ; *not* htmlized, so this can contain HTML |
---|
233 | " </body>\n" |
---|
234 | "</html>\n"))) |
---|
235 | (parameterize ((current-response |
---|
236 | (update-response (current-response) |
---|
237 | code: code |
---|
238 | reason: reason |
---|
239 | headers: |
---|
240 | (headers |
---|
241 | `((content-type text/html) |
---|
242 | (content-length ,(string-length output))) |
---|
243 | (response-headers (current-response)))))) |
---|
244 | (write-logged-response) |
---|
245 | (display output (response-port (current-response)))))) |
---|
246 | |
---|
247 | (define (send-static-file filename) |
---|
248 | (condition-case |
---|
249 | (let* ((path (make-pathname (root-path) filename)) |
---|
250 | (fd (file-open path (+ open/binary open/rdonly)))) |
---|
251 | (with-headers `((content-length ,(file-size path)) |
---|
252 | (content-type ,(extension->mime-type |
---|
253 | (pathname-extension filename)))) |
---|
254 | (lambda () |
---|
255 | (write-logged-response) |
---|
256 | (handle-exceptions exn (begin |
---|
257 | (file-close fd) |
---|
258 | (signal exn)) |
---|
259 | (sendfile fd (response-port (current-response)))) |
---|
260 | (file-close fd)))) |
---|
261 | ((exn i/o file) (send-status 403 "Forbidden")))) |
---|
262 | |
---|
263 | (define (with-headers new-headers thunk) |
---|
264 | (parameterize ((current-response |
---|
265 | (update-response |
---|
266 | (current-response) |
---|
267 | headers: (headers new-headers |
---|
268 | (response-headers (current-response)))))) |
---|
269 | (thunk))) |
---|
270 | |
---|
271 | (define (process-directory path) |
---|
272 | (let ((index-page (find (lambda (ip) |
---|
273 | (file-exists? |
---|
274 | (make-pathname (list (root-path) path) ip))) |
---|
275 | (index-files)))) |
---|
276 | (if index-page |
---|
277 | (process-entry path index-page '()) |
---|
278 | ((handle-directory) (make-pathname "/" path))))) |
---|
279 | |
---|
280 | ;; If an URL is missing a trailing slash, instead of directly serving |
---|
281 | ;; its index-file, redirect to the URL _with_ trailing slash. This |
---|
282 | ;; prevents problems with relative references since the directory |
---|
283 | ;; would be seen as the file component in the path and get replaced. |
---|
284 | (define (redirect-directory-root path) |
---|
285 | (let ((new-path (uri-path (uri-reference (string-append path "/"))))) |
---|
286 | (with-headers `((location ,(update-uri (server-root-uri) |
---|
287 | path: new-path))) |
---|
288 | (lambda () (send-status 301 "Moved permanently"))))) |
---|
289 | |
---|
290 | (define (apply-access-file path continue) |
---|
291 | (let ((file (make-pathname path (access-file)))) |
---|
292 | (if (and (access-file) (file-exists? file)) |
---|
293 | ((eval (call-with-input-file file read)) continue) |
---|
294 | (continue)))) |
---|
295 | |
---|
296 | ;; Is the file impossible to be requested directly? |
---|
297 | ;; |
---|
298 | ;; Any file that the the filesystem is incapable of representing is |
---|
299 | ;; considered impossible to request. This includes files with a name that |
---|
300 | ;; includes a slash, and "." and ".." because they are special files. |
---|
301 | ;; If this is requested, it's probably an encoded traversal attack |
---|
302 | (define (impossible-filename? name) |
---|
303 | (or (string=? name ".") (string=? name "..") (string-index name #\/))) |
---|
304 | |
---|
305 | (define (process-entry previous-path fragment remaining-path) |
---|
306 | (let* ((current-path (make-pathname previous-path fragment)) |
---|
307 | (full-path (make-pathname (root-path) current-path))) |
---|
308 | (cond |
---|
309 | ((impossible-filename? fragment) |
---|
310 | ((handle-not-found) (make-pathname "/" current-path))) |
---|
311 | ((directory? full-path) |
---|
312 | (apply-access-file full-path |
---|
313 | (lambda () |
---|
314 | (match remaining-path |
---|
315 | (() (redirect-directory-root (make-pathname "/" current-path))) |
---|
316 | (("") (process-directory current-path)) |
---|
317 | (else (process-entry current-path |
---|
318 | (car remaining-path) |
---|
319 | (cdr remaining-path))))))) |
---|
320 | ((file-exists? full-path) |
---|
321 | (parameterize ((current-pathinfo remaining-path) |
---|
322 | (current-file (make-pathname "/" current-path))) |
---|
323 | ((handle-file) (current-file)))) ;; hmm, not too useful |
---|
324 | (else ((handle-not-found) (make-pathname "/" current-path)))))) |
---|
325 | |
---|
326 | ;; Determine the vhost and port to use. This follows RFC 2616, section 5.2: |
---|
327 | ;; If request URL is absolute, use that. Otherwise, look at the Host header. |
---|
328 | ;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of |
---|
329 | ;; RFC 2616. If no host line is present, it returns the default host |
---|
330 | ;; for HTTP/1.0. |
---|
331 | (define (determine-vhost) |
---|
332 | (let* ((request-uri (request-uri (current-request))) |
---|
333 | (host-header (header-value 'host (request-headers (current-request))))) |
---|
334 | (if (and (= (request-major (current-request)) 1) |
---|
335 | (>= (request-minor (current-request)) 1) |
---|
336 | (not host-header)) |
---|
337 | #f |
---|
338 | (or (uri-host request-uri) |
---|
339 | (if host-header |
---|
340 | (car host-header) |
---|
341 | (default-host)))))) |
---|
342 | |
---|
343 | (define (server-root-uri) |
---|
344 | (let ((uri (request-uri (current-request)))) |
---|
345 | (if (absolute-uri? uri) |
---|
346 | uri |
---|
347 | (let ((host (determine-vhost)) |
---|
348 | (scheme 'http) ; find out the scheme from port if https is allowed |
---|
349 | (port (server-port))) |
---|
350 | (update-uri uri scheme: scheme port: port host: host))))) |
---|
351 | |
---|
352 | (define request-restarter (make-parameter #f)) ; Internal parameter |
---|
353 | |
---|
354 | (define (restart-request req) |
---|
355 | ((request-restarter) req (request-restarter))) |
---|
356 | |
---|
357 | (define (handle-incoming-request in out) |
---|
358 | (handle-exceptions exn ; This should probably be more fine-grained |
---|
359 | (begin (close-input-port in) |
---|
360 | (close-output-port out) |
---|
361 | #f) ; Do not keep going |
---|
362 | (receive (req cont) |
---|
363 | (call/cc (lambda (c) (values (read-request in) c))) |
---|
364 | (parameterize ((current-request req) |
---|
365 | (current-response |
---|
366 | (make-response port: out |
---|
367 | headers: (headers |
---|
368 | `((content-type text/html) |
---|
369 | (server ,(server-software)))))) |
---|
370 | (request-restarter cont)) |
---|
371 | (handle-exceptions exn |
---|
372 | (begin |
---|
373 | ((handle-exception) exn |
---|
374 | (with-output-to-string print-call-chain)) |
---|
375 | #f) ; Do not keep going |
---|
376 | (let ((path (uri-path (request-uri req))) |
---|
377 | (host (determine-vhost))) |
---|
378 | (if (and host |
---|
379 | (pair? path) ;; XXX change this to absolute-path? |
---|
380 | (eq? (car path) '/)) |
---|
381 | (let ((handler |
---|
382 | (alist-ref host (vhost-map) |
---|
383 | (lambda (h _) |
---|
384 | (if (not (regexp? h)) |
---|
385 | (string-match (regexp h #t) host) |
---|
386 | (string-match h host)))))) |
---|
387 | (if handler |
---|
388 | (handler (lambda () (process-entry "" "" (cdr path)))) |
---|
389 | ;; Is this ok? |
---|
390 | ((handle-not-found) path))) |
---|
391 | ;; No host or non-absolute URI in the request is an error. |
---|
392 | (send-status 400 "Bad request" |
---|
393 | "<p>Your client sent a request that the server did not understand</p>")) |
---|
394 | (handle-another-request?))))))) ; Keep going? |
---|
395 | |
---|
396 | (define (htmlize str) |
---|
397 | (string-translate* str '(("<" . "<") (">" . ">") |
---|
398 | ("\"" . """) ("'" . "'") ("&" . "&")))) |
---|
399 | |
---|
400 | ;; Do we want this here? |
---|
401 | (unless (eq? (build-platform) 'msvc) |
---|
402 | (set-signal-handler! signal/int (lambda (sig) (exit 1)))) |
---|
403 | |
---|
404 | (define (switch-user/group user group) |
---|
405 | (when group ; group first, since only superuser can switch groups |
---|
406 | (let ((ginfo (group-information group))) |
---|
407 | (unless ginfo |
---|
408 | (error "Group does not exist" group)) |
---|
409 | (set! (current-group-id) (list-ref ginfo 2)))) |
---|
410 | (when user |
---|
411 | (let ((uinfo (user-information user))) |
---|
412 | (unless uinfo |
---|
413 | (error "User does not exist" user)) |
---|
414 | (setenv "HOME" (list-ref uinfo 5)) |
---|
415 | (initialize-groups user (list-ref uinfo 3)) |
---|
416 | (unless group ; Already changed to target group? |
---|
417 | (set! (current-group-id) (list-ref uinfo 3))) |
---|
418 | (set! (current-user-id) (list-ref uinfo 2))))) |
---|
419 | |
---|
420 | (define (mutex-update! m op) |
---|
421 | (dynamic-wind |
---|
422 | (lambda () (mutex-lock! m)) |
---|
423 | (lambda () (mutex-specific-set! m (op (mutex-specific m)))) |
---|
424 | (lambda () (mutex-unlock! m)))) |
---|
425 | |
---|
426 | (define (make-mutex/value name value) |
---|
427 | (let ((m (make-mutex name))) |
---|
428 | (mutex-specific-set! m value) |
---|
429 | m)) |
---|
430 | |
---|
431 | (define (start-server #!key |
---|
432 | (port (server-port)) |
---|
433 | (ssl-context (server-ssl-context))) |
---|
434 | (parameterize ((load-verbose #f)) |
---|
435 | (letrec ((thread-count (make-mutex/value 'thread-count 0)) |
---|
436 | (listener (if ssl-context |
---|
437 | (ssl-listen port 4 #f ssl-context) |
---|
438 | (tcp-listen port))) |
---|
439 | (accept-next-connection |
---|
440 | (lambda () |
---|
441 | (if (>= (mutex-specific thread-count) (max-connections)) |
---|
442 | (thread-yield!) ; Can't accept right now, wait & try again |
---|
443 | (receive (in out) |
---|
444 | (if ssl-context |
---|
445 | (ssl-accept listener) |
---|
446 | (tcp-accept listener)) |
---|
447 | (mutex-update! thread-count add1) |
---|
448 | (thread-start! |
---|
449 | (lambda () |
---|
450 | ;; thread-count _must_ be updated, so trap all exns |
---|
451 | (handle-exceptions |
---|
452 | e (void) |
---|
453 | (receive (local remote) |
---|
454 | (tcp-addresses in) |
---|
455 | (log-to (debug-log) |
---|
456 | "~A: incoming request from ~A" |
---|
457 | (thread-name (current-thread)) remote) |
---|
458 | ;; This won't change during the session |
---|
459 | (parameterize ((remote-address remote) |
---|
460 | (local-address local) |
---|
461 | (handle-another-request? #t)) |
---|
462 | (let handle-next-request () |
---|
463 | (when (handle-incoming-request in out) |
---|
464 | (log-to (debug-log) |
---|
465 | "~A: kept alive" |
---|
466 | (thread-name (current-thread))) |
---|
467 | (handle-next-request))) |
---|
468 | (log-to (debug-log) |
---|
469 | "~A: closing off" |
---|
470 | (thread-name (current-thread))) |
---|
471 | (close-input-port in) |
---|
472 | (close-output-port out)))) |
---|
473 | (mutex-update! thread-count sub1))))) |
---|
474 | (accept-next-connection)))) |
---|
475 | ;; Drop privileges ASAP, now the TCP listener has been created |
---|
476 | (switch-user/group (spiffy-user) (spiffy-group)) |
---|
477 | (accept-next-connection)))) |
---|
478 | |
---|
479 | ) |
---|