source: project/release/4/spiffy/trunk/spiffy.scm @ 30267

Last change on this file since 30267 was 30267, checked in by sjamaan, 7 years ago

Spiffy: Use software-unparser instead of product-unparser, and bump intarweb dependency ; just in case

File size: 28.3 KB
Line 
1;;
2;; Spiffy the web server
3;;
4; Copyright (c) 2007-2014, 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(module spiffy
39  (start-server switch-user/group accept-loop
40   with-headers send-status send-response send-static-file log-to
41   write-logged-response build-error-message
42   current-request local-address remote-address secure-connection?
43   trusted-proxies current-response current-file current-pathinfo
44   server-software root-path server-port
45   server-bind-address index-files mime-type-map default-mime-type
46   file-extension->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)
53(use extras ports files data-structures srfi-1 srfi-13 srfi-14 srfi-18
54     tcp posix irregex uri-common sendfile intarweb)
55
56(define version 5)
57(define release 3)
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(define secure-connection?  (make-parameter #f))
67
68;;; Configuration
69(define server-software     (make-parameter `(("Spiffy"
70                                               ,(conc version "." release)
71                                               ,(conc "Running on Chicken "
72                                                      (chicken-version))))))
73(define root-path           (make-parameter "./web"))
74(define server-port         (make-parameter 8080))
75(define server-bind-address (make-parameter #f))
76(define index-files         (make-parameter '("index.html" "index.xhtml")))
77(define trusted-proxies     (make-parameter '()))
78
79;; See http://www.iana.org/assignments/media-types/ for a full list
80;; with links to RFCs describing the gory details.
81(define mime-type-map
82  (make-parameter
83   '(("html" . text/html)
84     ("xhtml" . application/xhtml+xml)
85     ("js"  . application/javascript)
86     ("css" . text/css)
87     ("png" . image/png)
88     ;; A charset parameter is STRONGLY RECOMMENDED by RFC 3023 but it overrides
89     ;; document declarations, so don't supply it (assume nothing about files)
90     ("xml" . application/xml)
91     ;; Use text/xml only if it is *truly* human-readable (eg docbook, recipe...)
92     #;("xml" . text/xml)
93     ("pdf" . application/pdf)
94     ("jpeg" . image/jpeg)
95     ("jpg" . image/jpeg)
96     ("gif" . image/gif)
97     ("ico" . image/vnd.microsoft.icon)
98     ("svg" . image/svg+xml)
99     ("txt" . text/plain))))
100(define default-mime-type (make-parameter 'application/octet-stream))
101(define file-extension-handlers (make-parameter '()))
102(define default-host    (make-parameter "localhost")) ;; XXX Can we do without?
103(define vhost-map       (make-parameter `((".*" . ,(lambda (cont) (cont))))))
104(define access-log      (make-parameter #f))
105(define error-log       (make-parameter (current-error-port)))
106(define debug-log       (make-parameter #f))
107(define spiffy-user     (make-parameter #f))
108(define spiffy-group    (make-parameter #f))
109(define access-file     (make-parameter #f))
110(define max-connections (make-parameter 1024))
111
112;;; Custom handlers
113(define handle-directory
114  (make-parameter
115   (lambda (path)
116     (send-status 'forbidden))))
117;; TODO: maybe simplify this so it falls into more reusable pieces
118(define handle-file
119  (make-parameter
120   (lambda (path)
121     (let* ((ext (pathname-extension path))
122            (h (file-extension-handlers))
123            (m '(HEAD GET))
124            (handler (or (and ext (alist-ref ext h string-ci=?))
125                         (lambda (fn)
126                           ;; Check here for allowed methods, because
127                           ;; for example a .cgi handler might allow POST,
128                           ;; and anyone can re-use send-static-file to
129                           ;; send a file even when another method is used.
130                           (if (not (memq (request-method (current-request)) m))
131                               (with-headers `((allow . ,m))
132                                 (lambda () (send-status 'method-not-allowed)))
133                               (send-static-file fn))))))
134       (handler path)))))
135(define handle-not-found
136  (make-parameter
137   (lambda (path)
138     (send-status 'not-found
139                  "<p>The resource you requested could not be found</p>"))))
140(define handle-exception
141  (make-parameter
142   (lambda (exn chain)
143     (log-to (error-log) "[~A] \"~A ~A HTTP/~A.~A\" ~A"
144             (seconds->string (current-seconds))
145             (request-method (current-request))
146             (uri->string (request-uri (current-request)))
147             (request-major (current-request))
148             (request-minor (current-request))
149             (build-error-message exn chain #t))
150     (send-status 'internal-server-error))))
151
152;; This is very powerful, but it also means people need to write quite
153;; a bit of code to change the line slightly. In this respect Apache-style
154;; log format strings could be better...
155(define handle-access-logging
156  (make-parameter
157   (lambda ()
158     (and-let* ((logfile (access-log))
159                (h (request-headers (current-request))))
160       (log-to logfile
161               "~A [~A] \"~A ~A HTTP/~A.~A\" ~A \"~A\" \"~A\""
162               (remote-address)
163               (seconds->string (current-seconds))
164               (request-method (current-request))
165               (uri->string (request-uri (current-request)))
166               (request-major (current-request))
167               (request-minor (current-request))
168               (response-code (current-response))
169               (uri->string (header-value 'referer h (uri-reference "-")))
170               (let ((ua (header-contents 'user-agent h)))
171                 (if ua (software-unparser ua) "**Unknown product**")))))))
172
173;;;; End of configuration parameters
174
175(define (with-output-to-log log thunk)
176  (when log
177    (if (output-port? log)
178        (with-output-to-port log thunk)
179        (with-output-to-file log thunk append:))))
180
181(define (log-to log fmt . rest)
182  (with-output-to-log log
183    (lambda ()
184      (apply printf fmt rest)
185      (newline))))
186
187;; Handy shortcut for logging to the debug log with the current
188;; thread name prefixed to the log.
189(define (debug! m . args)
190  (apply log-to (debug-log)
191         (conc "~A: " m) (thread-name (current-thread)) args))
192
193(define build-error-message
194  (let* ((cpa condition-property-accessor)
195         (exn-message (cpa 'exn 'message "(no message)"))
196         (exn-location (cpa 'exn 'location "*ERROR LOCATION UNKNOWN*"))
197         (exn-arguments (cpa 'exn 'arguments '()))
198         (exn? (condition-predicate 'exn)))
199    (lambda (exn chain #!optional raw-output)
200      (with-output-to-string
201        (lambda ()
202          (if (exn? exn)
203              (begin
204                (unless raw-output (display "<h2>"))
205                (display "Error:")
206                (and-let* ((loc (exn-location exn)))
207                  (if raw-output
208                      (printf " (~A)" (->string loc))
209                      (printf " (<em>~A</em>)" (htmlize (->string loc)))))
210                (if raw-output
211                    (printf "\n~A\n" (exn-message exn))
212                    (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn))))
213                (let ((args (exn-arguments exn)))
214                  (unless (null? args)
215                    (unless raw-output (printf "<ul>"))
216                    (for-each
217                     (lambda (a)
218                       (##sys#with-print-length-limit
219                        120
220                        (lambda ()
221                          (if raw-output
222                              (printf "~S~%" a)
223                              (printf "<li>~A</li>"
224                                (htmlize (format "~S" a)))))))
225                     ;; Workaround for truly broken libraries (like intarweb)
226                     ;; which don't pass lists in the 'arguments property
227                     (if (list? args) args (list args)))
228                    (unless raw-output
229                      (printf "</ul>"))))
230                (if raw-output
231                    (print chain)
232                    (printf "<pre>~a</pre>" (htmlize chain))))
233              (begin
234                (##sys#with-print-length-limit
235                 120
236                 (lambda ()
237                   (if raw-output
238                       (printf "Uncaught exception:\n~S\n" exn)
239                       (printf "<h2>Uncaught exception:</h2>\n~S\n" exn)))))))))))
240
241(define (file-extension->mime-type ext)
242  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
243
244(define handle-another-request? (make-parameter #f)) ;; Internal parameter
245
246(define (write-logged-response)
247  ((handle-access-logging))
248  (handle-another-request? (and (keep-alive? (current-request))
249                                (keep-alive? (current-response))))
250  ;; RFC 2616, 14.18:
251  ;; "Origin servers MUST include a Date header field in all responses
252  ;;  [...] In theory, the date ought to represent the moment just before
253  ;;  the entity is generated."
254  ;; So we do it here, as this is the very last moment where we're able
255  ;; to get a current timestamp.
256  (with-headers `((date #(,(seconds->utc-time (current-seconds)))))
257    (lambda ()
258      (write-response (current-response)))))
259
260;; A simple utility procedure to render a status code with message
261;; TODO: This is a bit ugly and should be rewritten to be simpler.
262(define (send-status st #!optional reason-or-text text)
263  (let*-values
264      (((status) (if (symbol? st) st (response-status st)))
265       ((code status-reason) (http-status->code&reason status))
266       ((reason) (if (symbol? st) status-reason reason-or-text))
267       ((htmlized-reason) (htmlize reason))
268       ((message) (or (if (symbol? st) reason-or-text text) ""))
269       ((output)
270        (conc "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
271              "<!DOCTYPE html\n"
272              "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"
273              "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
274              "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n"
275              "      xml:lang=\"en\" lang=\"en\">\n"
276              "  <head>\n"
277              "    <title>" code " - " htmlized-reason "</title>\n"
278              "  </head>\n"
279              "  <body>\n"
280              "    <h1>" code " - " htmlized-reason "</h1>\n"
281              "    " message "\n"    ; *not* htmlized, so this can contain HTML
282              "  </body>\n"
283              "</html>\n")))
284    (send-response code: code reason: reason
285                   body: output headers: '((content-type text/html)))))
286
287(define (call-with-input-file* file proc)
288  (call-with-input-file file (lambda (p)
289                               (handle-exceptions exn
290                                 (begin (close-input-port p) (raise exn))
291                                 (proc p)))))
292
293(define (send-response #!key code reason status body (new-headers '()))
294  (let* ((h (cons `(content-length ,(if body (string-length body) 0))
295                  new-headers))
296         (h (headers h (response-headers (current-response))))
297         (resp (if (and status (not code) (not reason))
298                   (update-response (current-response)
299                                    status: status headers: h)
300                   (update-response (current-response)
301                                    code: (or code 200) reason: (or reason "OK")
302                                    headers: h)))
303         (req (current-request)))
304    (parameterize ((current-response resp))
305      (write-logged-response)
306      (when (and body ((response-has-message-body-for-request?) resp req))
307        (display body (response-port resp))
308        (finish-response-body resp)))))
309
310(define (send-static-file filename)
311  (condition-case
312      (let* ((path (make-pathname (root-path) filename))
313             (h (request-headers (current-request)))
314             (size (file-size path))
315             (last-modified (file-modification-time path))
316             (etag (cons 'strong (conc size "-" last-modified)))
317             (unmodified (or (and-let* ((t (header-values 'if-none-match h)))
318                               (etag-matches? etag t))
319                             (and-let* ((t (header-value 'if-modified-since h)))
320                               (<= last-modified (utc-time->seconds t))))))
321        (parameterize ((current-response
322                        (if unmodified
323                            (update-response (current-response) status: 'not-modified)
324                            (current-response))))
325          (with-headers `((last-modified #(,(seconds->utc-time last-modified)))
326                          (etag ,etag)
327                          (content-length ,(if unmodified 0 size))
328                          (content-type ,(file-extension->mime-type
329                                          (pathname-extension filename))))
330            (lambda ()
331              (call-with-input-file*
332               path (lambda (f)
333                      (write-logged-response)
334                       (when ((response-has-message-body-for-request?)
335                              (current-response) (current-request))
336                         (sendfile f (response-port (current-response))))))))))
337    ((exn i/o file) (send-status 'forbidden))))
338
339(define (with-headers new-headers thunk)
340  (parameterize ((current-response
341                  (update-response (current-response)
342                                   headers: (headers new-headers
343                                                     (response-headers
344                                                      (current-response))))))
345    (thunk)))
346
347(define (process-directory path)
348  (let ((index-page (find (lambda (ip)
349                            (file-exists?
350                             (make-pathname (list (root-path) path) ip)))
351                          (index-files))))
352    (if index-page
353        (process-entry path index-page '())
354        ((handle-directory) (make-pathname "/" path)))))
355
356;; If an URL is missing a trailing slash, instead of directly serving
357;; its index-file, redirect to the URL _with_ trailing slash.  This
358;; prevents problems with relative references since the directory
359;; would be seen as the file component in the path and get replaced.
360(define (redirect-directory-root path)
361  (let ((new-path `(/ ,@(string-split (string-append path "/") "/") "")))
362   (with-headers `((location ,(update-uri (request-uri (current-request))
363                                          path: new-path)))
364     (lambda () (send-status 'moved-permanently)))))
365
366(define (apply-access-file path continue)
367  (let ((file (make-pathname path (access-file))))
368    (if (and (access-file) (file-exists? file))
369        ((eval (call-with-input-file* file read)) continue)
370        (continue))))
371
372;; Is the file impossible to be requested directly?
373;;
374;; Any file that the the filesystem is incapable of representing is
375;; considered impossible to request.  This includes ".", "..", and
376;; files with a name containing a NUL or a slash; they are all special
377;; files.  Such a request is probably an encoded traversal attack.
378(define (impossible-filename? name)
379  (or (string=? name ".") (string=? name "..")
380      (string-index name (char-set #\/ #\nul))))
381
382(define (process-entry previous-path fragment remaining-path)
383  (let* ((current-path (make-pathname previous-path fragment))
384         (full-path (make-pathname (root-path) current-path)))
385    (cond
386     ((impossible-filename? fragment)
387      ((handle-not-found) (make-pathname "/" current-path)))
388     ((directory? full-path)
389      (apply-access-file full-path
390                         (lambda ()
391                           (if (null? remaining-path)
392                               (redirect-directory-root
393                                (make-pathname "/" current-path))
394                               ;; Ignore empty path components like most
395                               ;; webservers do.  It's slightly broken but
396                               ;; enough scripts generate bad URIs that it's
397                               ;; a useful thing to do.  (maybe we shouldn't?)
398                               (let lp ((remaining-path remaining-path))
399                                 (cond
400                                  ((null? remaining-path)
401                                   (process-directory current-path))
402                                  ((string=? "" (car remaining-path))
403                                   (lp (cdr remaining-path)))
404                                  (else
405                                   (process-entry current-path
406                                                  (car remaining-path)
407                                                  (cdr remaining-path)))))))))
408     ((file-exists? full-path)
409      (parameterize ((current-pathinfo remaining-path)
410                     (current-file (make-pathname "/" current-path)))
411        ((handle-file) (current-file)))) ;; hmm, not too useful
412     (else ((handle-not-found) (make-pathname "/" current-path))))))
413
414;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
415;; If request URL is absolute, use that.  Otherwise, look at the Host header.
416;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
417;; RFC 2616.  If no host line is present, it returns the default host
418;; for HTTP/1.0.
419(define (determine-vhost req)
420  (let* ((uri (request-uri req))
421         (host-header (header-value 'host (request-headers req))))
422    (if (and (= (request-major req) 1)
423             (>= (request-minor req) 1)
424             (not host-header))
425        #f
426        (or (and-let* ((host (uri-host uri))
427                       (port (uri-port uri)))
428              (cons host port))
429            host-header
430            (cons (default-host) (server-port))))))
431
432;; Make the request uri a full uri including the host and port
433(define (normalize-uri req)
434  (let ((uri (request-uri req)))
435    (if (absolute-uri? uri)
436        uri
437        (let ((host&port (determine-vhost req))
438              (scheme (if (secure-connection?) 'https 'http)))
439          (update-uri uri scheme: scheme
440                      host: (and host&port (car host&port))
441                      port: (and host&port (cdr host&port)))))))
442
443(define request-restarter (make-parameter #f)) ; Internal parameter
444
445(define (restart-request req)
446  (debug! "Restarting request from ~A (with uri: ~A)"
447          (remote-address) (request-uri req))
448  ((request-restarter) req (request-restarter)))
449
450(define (determine-remote-address-with-trusted-proxies req)
451  ;; If the remote end is untrusted, that's the remote address.  If it
452  ;; is trusted, see for whom it forwarded the request and loop.  Take
453  ;; care to stop on a trusted host if there are no more forwarded-for
454  ;; entries (a request may originate from a trusted host).
455  (let lp ((address-chain (cons (remote-address)
456                                (reverse
457                                 (header-values 'x-forwarded-for
458                                                (request-headers req))))))
459    (if (and (member (car address-chain) (trusted-proxies))
460             (not (null? (cdr address-chain))))
461        (lp (cdr address-chain))
462        (car address-chain))))
463
464(define (handle-incoming-request in out)
465  (handle-exceptions exn   ; This should probably be more fine-grained
466    (let ((chain (with-output-to-string print-call-chain)))
467      (close-input-port in)
468      (close-output-port out)
469      (debug! "~A" (build-error-message exn chain #t))
470      #f)                          ; Do not keep going
471    (receive (req cont)
472        (call/cc (lambda (c) (values (read-request in) c)))
473      (and req ; No request? Then the connection was closed. Don't keep going.
474           (parameterize ((remote-address
475                           (determine-remote-address-with-trusted-proxies req))
476                          (current-request
477                           (update-request req uri: (normalize-uri req)))
478                          (current-response
479                           (make-response
480                            port: out
481                            headers: (headers `((content-type text/html)
482                                                (server ,(server-software))))))
483                          (request-restarter cont))
484             (debug! "Handling request from ~A" (remote-address))
485             (handle-exceptions exn
486                 (begin
487                   ((handle-exception) exn
488                    (with-output-to-string print-call-chain))
489                   #f)                  ; Do not keep going
490               (let ((host (uri-host (request-uri (current-request)))))
491                 (if (and host (uri-path-absolute? (request-uri (current-request))))
492                     (let ((handler
493                            (alist-ref host (vhost-map)
494                                       (lambda (h _)
495                                         (irregex-match (irregex h 'i) host)))))
496                       (if handler
497                           (handler (lambda ()
498                                      (process-entry
499                                       "" ""
500                                       (cdr (uri-path (request-uri
501                                                       (current-request)))))))
502                           ;; Is this ok?
503                           ((handle-not-found)
504                            (uri-path (request-uri (current-request))))))
505                     ;; No host or non-absolute URI in the request is an error.
506                     (send-status 'bad-request
507                                  (conc "<p>Your client sent a request that "
508                                        "the server did not understand</p>")))
509                 (unless (##sys#slot out 8) ;; port-closed?
510                   (flush-output out))
511                 (handle-another-request?)))))))) ; Keep going?
512
513(define (htmlize str)
514  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
515                           ("\"" . "&quot;") ("'" . "&#x27;") ("&" . "&amp;"))))
516
517;; Do we want this here?
518(unless (eq? (build-platform) 'msvc)
519  (set-signal-handler! signal/int (lambda (sig) (exit 1))))
520
521(define (switch-user/group user group)
522  (when group    ; group first, since only superuser can switch groups
523    (let ((ginfo (group-information group)))
524      (unless ginfo
525        (error "Group does not exist" group))
526      (set! (current-group-id) (list-ref ginfo 2))))
527  (when user
528    (let ((uinfo (user-information user)))
529      (unless uinfo
530        (error "User does not exist" user))
531      (setenv "HOME" (list-ref uinfo 5))
532      (initialize-groups user (list-ref uinfo 3))
533      (unless group                 ; Already changed to target group?
534        (set! (current-group-id) (list-ref uinfo 3)))
535      (set! (current-user-id) (list-ref uinfo 2)))))
536
537(define (mutex-update! m op)
538  (dynamic-wind
539      (lambda () (mutex-lock! m))
540      (lambda () (mutex-specific-set! m (op (mutex-specific m))))
541      (lambda () (mutex-unlock! m))))
542
543(define (make-mutex/value name value)
544  (let ((m (make-mutex name)))
545    (mutex-specific-set! m value)
546    m))
547
548;; Check whether the mutex has the correct state. If not, wait for a condition
549;; and try again
550(define (mutex-wait! m ok? condition)
551  (let retry ()
552    (mutex-lock! m)
553    (if (ok? (mutex-specific m))
554        (mutex-unlock! m)
555        (begin (mutex-unlock! m condition) (retry)))))
556
557;; Imports from the openssl egg, if available
558(define (dynamic-import module symbol default)
559  (handle-exceptions _ default (eval `(let () (use ,module) ,symbol))))
560
561(define ssl-port?
562  (dynamic-import 'openssl 'ssl-port? (lambda (v) #f)))
563
564(define ssl-port->tcp-port
565  (dynamic-import
566   'openssl 'ssl-port->tcp-port
567   (lambda (v) (error 'ssl-port->tcp-port "Expected an SSL port" v))))
568
569(define (ssl-or-tcp-addresses p)
570  (tcp-addresses (if (ssl-port? p) (ssl-port->tcp-port p) p)))
571
572(define (accept-loop listener accept #!optional (addresses ssl-or-tcp-addresses))
573  (let ((thread-count (make-mutex/value 'thread-count 0))
574        (thread-stopped! (make-condition-variable 'thread-stopped!))
575        (exn-message (condition-property-accessor 'exn 'message "(no message)")))
576    (let accept-next-connection ()
577      ;; Wait until we have a free connection slot
578      (mutex-wait! thread-count
579                   (lambda (count) (< count (max-connections)))
580                   thread-stopped!)
581      (handle-exceptions       ; Catch errors during TCP/SSL handshake
582          e (debug! "Connection handshake error: ~S" (exn-message e))
583          (let*-values (((in out)       (accept listener))
584                        ((local remote) (addresses in)))
585            (mutex-update! thread-count add1)
586            (thread-start!
587             (lambda ()
588               (debug! "Incoming request from ~A" remote)
589               ;; thread-count _must_ be updated, so trap all exns
590               (handle-exceptions
591                   e (debug! "Uncaught exception: ~S (SHOULD NOT HAPPEN!)"
592                            (exn-message e))
593                   ;; Most of these won't change during the session.
594                   ;; Some may be refined using info from headers after parsing
595                   (parameterize ((remote-address remote) ; Initial value
596                                  (local-address local)
597                                  ;; Believe the user when (s)he says it's a
598                                  ;; secure connection.  Otherwise try to
599                                  ;; detect it by checking for an SSL port.
600                                  (secure-connection?
601                                   (or (secure-connection?) (ssl-port? in)))
602                                  (handle-another-request? #t)
603                                  (load-verbose #f))
604                     (let handle-next-request ()
605                       (when (handle-incoming-request in out)
606                         (debug! "Kept alive")
607                         (handle-next-request)))
608                     (debug! "Closing off")
609                     (close-input-port in)
610                     (close-output-port out)))
611               (mutex-update! thread-count sub1)
612               ;; Wake up the accepting thread if it's asleep
613               (condition-variable-signal! thread-stopped!)))))
614      (accept-next-connection))))
615
616(define (start-server #!key
617                      (port (server-port))
618                      (bind-address (server-bind-address))
619                      (listen tcp-listen)
620                      (accept tcp-accept)
621                      (addresses ssl-or-tcp-addresses))
622  (let ((listener (listen port 100 bind-address)))
623    ;; Drop privileges ASAP, now the TCP listener has been created
624    (switch-user/group (spiffy-user) (spiffy-group))
625    ;; Make these parameters actual (start-server arg might override it)
626    (parameterize ((server-port port)
627                   (server-bind-address bind-address))
628      (accept-loop listener accept addresses))))
629
630)
Note: See TracBrowser for help on using the repository browser.