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

Last change on this file since 26191 was 26191, checked in by sjamaan, 10 years ago

spiffy: forgot to commit the actual code (not just tests) with r26184

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