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

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

spiffy: tag 4.14

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