diff options
Diffstat (limited to 'spiffy.scm')
| -rw-r--r-- | spiffy.scm | 667 |
1 files changed, 667 insertions, 0 deletions
diff --git a/spiffy.scm b/spiffy.scm new file mode 100644 index 0000000..91e6bee --- /dev/null +++ b/spiffy.scm @@ -0,0 +1,667 @@ +;; +;; Spiffy the web server +;; +; Copyright (c) 2007-2017, Peter Bex +; Copyright (c) 2000-2005, Felix L. Winkelmann +; All rights reserved. +; +; Redistribution and use in source and binary forms, with or without +; modification, are permitted provided that the following conditions +; are met: +; +; 1. Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; 2. Redistributions in binary form must reproduce the above copyright +; notice, this list of conditions and the following disclaimer in the +; documentation and/or other materials provided with the distribution. +; 3. Neither the name of the author nor the names of its +; contributors may be used to endorse or promote products derived +; from this software without specific prior written permission. +; +; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +; OF THE POSSIBILITY OF SUCH DAMAGE. +; +; Please report bugs, suggestions and ideas to the CHICKEN Trac +; ticket tracking system (assign tickets to user 'sjamaan'): +; http://trac.callcc.org + +(module spiffy + (start-server switch-user/group accept-loop + with-headers send-status send-response send-static-file log-to + write-logged-response build-error-message + current-request local-address remote-address secure-connection? + trusted-proxies current-response current-file current-pathinfo + server-software root-path server-port + server-bind-address index-files mime-type-map default-mime-type + file-extension->mime-type file-extension-handlers + default-host vhost-map access-log error-log debug-log + spiffy-user spiffy-group access-file max-connections + handle-file handle-directory handle-not-found handle-exception + handle-access-logging restart-request htmlize) + +(import scheme (chicken base) (chicken file) (chicken port) + (chicken string) (chicken tcp) (chicken irregex) + (chicken pathname) (chicken platform) (chicken format) + (chicken time) (chicken time posix) (chicken condition) + (chicken file posix) (chicken process signal) (chicken load) + (chicken process-context) (chicken process-context posix) + srfi-1 srfi-13 srfi-14 srfi-18 + posix-groups uri-common sendfile + (rename intarweb (headers intarweb:headers))) + +(define version 6) +(define release 0) + +;;; Request processing information +(define current-request (make-parameter #f)) +(define current-response (make-parameter #f)) +(define current-file (make-parameter #f)) +(define current-pathinfo (make-parameter #f)) +(define local-address (make-parameter #f)) +(define remote-address (make-parameter #f)) +(define secure-connection? (make-parameter #f)) + +;;; Configuration +(define server-software (make-parameter `(("Spiffy" + ,(conc version "." release) + ,(conc "Running on CHICKEN " + (chicken-version)))))) +(define root-path (make-parameter "./web")) +(define server-port (make-parameter 8080)) +(define server-bind-address (make-parameter #f)) +(define index-files (make-parameter '("index.html" "index.xhtml"))) +(define trusted-proxies (make-parameter '())) + +;; See http://www.iana.org/assignments/media-types/ for a full list +;; with links to RFCs describing the gory details. +(define mime-type-map + (make-parameter + '(("html" . text/html) + ("xhtml" . application/xhtml+xml) + ("js" . application/javascript) + ("css" . text/css) + ("png" . image/png) + ;; A charset parameter is STRONGLY RECOMMENDED by RFC 3023 but it overrides + ;; document declarations, so don't supply it (assume nothing about files) + ("xml" . application/xml) + ;; Use text/xml only if it is *truly* human-readable (eg docbook, recipe...) + #;("xml" . text/xml) + ("pdf" . application/pdf) + ("jpeg" . image/jpeg) + ("jpg" . image/jpeg) + ("gif" . image/gif) + ("ico" . image/vnd.microsoft.icon) + ("svg" . image/svg+xml) + ("txt" . text/plain)))) +(define default-mime-type (make-parameter 'application/octet-stream)) +(define file-extension-handlers (make-parameter '())) +(define default-host (make-parameter "localhost")) ;; XXX Can we do without? +(define vhost-map (make-parameter `((".*" . ,(lambda (cont) (cont)))))) +(define access-log (make-parameter #f)) +(define error-log (make-parameter (current-error-port))) +(define debug-log (make-parameter #f)) +(define spiffy-user (make-parameter #f)) +(define spiffy-group (make-parameter #f)) +(define access-file (make-parameter #f)) +(define max-connections (make-parameter 1024)) + +;;; Custom handlers +(define handle-directory + (make-parameter + (lambda (path) + (send-status 'forbidden)))) +;; TODO: maybe simplify this so it falls into more reusable pieces +(define handle-file + (make-parameter + (lambda (path) + (let* ((ext (pathname-extension path)) + (h (file-extension-handlers)) + (m '(HEAD GET)) + (handler (or (and ext (alist-ref ext h string-ci=?)) + (lambda (fn) + ;; Check here for allowed methods, because + ;; for example a .cgi handler might allow POST, + ;; and anyone can re-use send-static-file to + ;; send a file even when another method is used. + (if (not (memq (request-method (current-request)) m)) + (with-headers `((allow . ,m)) + (lambda () (send-status 'method-not-allowed))) + (send-static-file fn)))))) + (handler path))))) +(define handle-not-found + (make-parameter + (lambda (path) + (send-status 'not-found + "<p>The resource you requested could not be found</p>")))) +(define handle-exception + (make-parameter + (lambda (exn chain) + (log-to (error-log) "[~A] \"~A ~A HTTP/~A.~A\" ~A" + (seconds->string (current-seconds)) + (request-method (current-request)) + (uri->string (request-uri (current-request))) + (request-major (current-request)) + (request-minor (current-request)) + (build-error-message exn chain #t)) + (send-status 'internal-server-error)))) + +;; This is very powerful, but it also means people need to write quite +;; a bit of code to change the line slightly. In this respect Apache-style +;; log format strings could be better... +(define handle-access-logging + (make-parameter + (lambda () + (and-let* ((logfile (access-log)) + (h (request-headers (current-request)))) + (log-to logfile + "~A [~A] \"~A ~A HTTP/~A.~A\" ~A \"~A\" \"~A\"" + (remote-address) + (seconds->string (current-seconds)) + (request-method (current-request)) + (uri->string (request-uri (current-request))) + (request-major (current-request)) + (request-minor (current-request)) + (response-code (current-response)) + (uri->string (header-value 'referer h (uri-reference "-"))) + (let ((ua (header-contents 'user-agent h))) + (if ua (software-unparser ua) "**Unknown product**"))))))) + +;;;; End of configuration parameters + +(define (with-output-to-log log thunk) + (when log + (if (output-port? log) + (with-output-to-port log thunk) + (with-output-to-file log thunk append:)))) + +(define (log-to log fmt . rest) + (with-output-to-log log + (lambda () + (apply printf fmt rest) + (newline)))) + +;; Handy shortcut for logging to the debug log with the current +;; thread name prefixed to the log. +(define (debug! m . args) + (apply log-to (debug-log) + (conc "~A: " m) (thread-name (current-thread)) args)) + +(define build-error-message + (let* ((cpa condition-property-accessor) + (exn-message (cpa 'exn 'message "(no message)")) + (exn-location (cpa 'exn 'location "*ERROR LOCATION UNKNOWN*")) + (exn-arguments (cpa 'exn 'arguments '())) + (exn? (condition-predicate 'exn))) + (lambda (exn chain #!optional raw-output) + (with-output-to-string + (lambda () + (if (exn? exn) + (begin + (unless raw-output (display "<h2>")) + (display "Error:") + (and-let* ((loc (exn-location exn))) + (if raw-output + (printf " (~A)" (->string loc)) + (printf " (<em>~A</em>)" (htmlize (->string loc))))) + (if raw-output + (printf "\n~A\n" (exn-message exn)) + (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn)))) + (let ((args (exn-arguments exn))) + (unless (null? args) + (unless raw-output (printf "<ul>")) + (for-each + (lambda (a) + (##sys#with-print-length-limit + 120 + (lambda () + (if raw-output + (printf "~S~%" a) + (printf "<li>~A</li>" + (htmlize (format "~S" a))))))) + ;; Workaround for truly broken libraries (like intarweb) + ;; which don't pass lists in the 'arguments property + (if (list? args) args (list args))) + (unless raw-output + (printf "</ul>")))) + (if raw-output + (print chain) + (printf "<pre>~a</pre>" (htmlize chain)))) + (begin + (##sys#with-print-length-limit + 120 + (lambda () + (if raw-output + (printf "Uncaught exception:\n~S\n" exn) + (printf "<h2>Uncaught exception:</h2>\n~S\n" exn))))))))))) + +(define (file-extension->mime-type ext) + (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type))) + +(define handle-another-request? (make-parameter #f)) ;; Internal parameter + +(define (write-logged-response) + ((handle-access-logging)) + (handle-another-request? (and (keep-alive? (current-request)) + (keep-alive? (current-response)))) + ;; RFC 2616, 14.18: + ;; "Origin servers MUST include a Date header field in all responses + ;; [...] In theory, the date ought to represent the moment just before + ;; the entity is generated." + ;; So we do it here, as this is the very last moment where we're able + ;; to get a current timestamp. + (with-headers `((date #(,(seconds->utc-time (current-seconds)) ()))) + (lambda () + (write-response (current-response))))) + +;; A simple utility procedure to render a status code with message +;; TODO: This is a bit ugly and should be rewritten to be simpler. +(define (send-status st #!optional reason-or-text text) + (let*-values + (((status) (if (symbol? st) st (response-status st))) + ((code status-reason) (http-status->code&reason status)) + ((reason) (if (symbol? st) status-reason reason-or-text)) + ((htmlized-reason) (htmlize reason)) + ((message) (or (if (symbol? st) reason-or-text text) "")) + ((output) + (conc "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n" + "<!DOCTYPE html\n" + " PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n" + " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" + "<html xmlns=\"http://www.w3.org/1999/xhtml\"\n" + " xml:lang=\"en\" lang=\"en\">\n" + " <head>\n" + " <title>" code " - " htmlized-reason "</title>\n" + " </head>\n" + " <body>\n" + " <h1>" code " - " htmlized-reason "</h1>\n" + " " message "\n" ; *not* htmlized, so this can contain HTML + " </body>\n" + "</html>\n"))) + (send-response code: code reason: reason + body: output headers: '((content-type text/html))))) + +(define (call-with-input-file* file proc) + (call-with-input-file file (lambda (p) + (handle-exceptions exn + (begin (close-input-port p) (raise exn)) + (proc p))) + #:binary)) + +(define (send-response #!key code reason status body (headers '())) + (let* ((new-headers (cons `(content-length ,(if body (string-length body) 0)) + headers)) + (h (intarweb:headers new-headers (response-headers (current-response)))) + (resp (if (and status (not code) (not reason)) + (update-response (current-response) + status: status headers: h) + (update-response (current-response) + code: (or code 200) reason: (or reason "OK") + headers: h))) + (req (current-request))) + (parameterize ((current-response resp)) + (write-logged-response) + (when (and body ((response-has-message-body-for-request?) resp req)) + (display body (response-port resp)) + (finish-response-body resp))))) + +(define (send-static-file filename) + (condition-case + (let* ((path (make-pathname (root-path) filename)) + (h (request-headers (current-request))) + (size (file-size path)) + (last-modified (file-modification-time path)) + (etag (cons 'strong (conc size "-" last-modified))) + (unmodified (or (and-let* ((t (header-values 'if-none-match h))) + (etag-matches? etag t)) + (and-let* ((t (header-value 'if-modified-since h))) + (<= last-modified (utc-time->seconds t)))))) + (parameterize ((current-response + (if unmodified + (update-response (current-response) status: 'not-modified) + (current-response)))) + (with-headers `((last-modified #(,(seconds->utc-time last-modified) ())) + (etag ,etag) + (content-length ,(if unmodified 0 size)) + (content-type ,(file-extension->mime-type + (pathname-extension filename)))) + (lambda () + (call-with-input-file* + path (lambda (f) + (write-logged-response) + (when ((response-has-message-body-for-request?) + (current-response) (current-request)) + (sendfile f (response-port (current-response)))))))))) + ((exn i/o file) (send-status 'forbidden)))) + +(define (with-headers new-headers thunk) + (parameterize ((current-response + (update-response + (current-response) + headers: + (intarweb:headers new-headers + (response-headers (current-response)))))) + (thunk))) + +(define (process-directory path) + (let ((index-page (find (lambda (ip) + (file-exists? + (make-pathname (list (root-path) path) ip))) + (index-files)))) + (if index-page + (process-entry path index-page '()) + ((handle-directory) (make-pathname "/" path))))) + +;; If an URL is missing a trailing slash, instead of directly serving +;; its index-file, redirect to the URL _with_ trailing slash. This +;; prevents problems with relative references since the directory +;; would be seen as the file component in the path and get replaced. +(define (redirect-directory-root path) + (let ((new-path `(/ ,@(string-split (string-append path "/") "/") ""))) + (with-headers `((location ,(update-uri (request-uri (current-request)) + path: new-path))) + (lambda () (send-status 'moved-permanently))))) + +(define (apply-access-file path continue) + (let ((file (make-pathname path (access-file)))) + (if (and (access-file) (file-exists? file)) + ((eval (call-with-input-file* file read)) continue) + (continue)))) + +;; Is the file impossible to be requested directly? +;; +;; Any file that the the filesystem is incapable of representing is +;; considered impossible to request. This includes ".", "..", and +;; files with a name containing a NUL or a slash; they are all special +;; files. Such a request is probably an encoded traversal attack. +;; +;; Please note that we disallow backslash even in a UNIX environment, +;; because core plays fast and loose with slashes and backslashes. +;; This causes the path "\.." (which strictly speaking is 100% +;; harmless on UNIX) to be converted to "/..", which opens up a path +;; traversal bug! So we work around this by adding a backslash to +;; invalid-set on UNIX as well. Because backslashes in filenames are +;; relatively rare, this won't cause too many additional problems... +;; This vulnerability was found by Benedikt Rosenau with the +;; Netsparker vulnerability scanner. +(define impossible-filename? + (let ((invalid-set (if (or ##sys#windows-platform + ;; This detects CHICKENs with the bug + (string=? (make-pathname "/" "\\") "/")) + (char-set #\\ #\/ #\nul) + (char-set #\/ #\nul)))) + (lambda (name) + (or (string=? name ".") (string=? name "..") + (string-index name invalid-set))))) + +(define (process-entry previous-path fragment remaining-path) + (let* ((current-path (make-pathname previous-path fragment)) + (full-path (make-pathname (root-path) current-path))) + (cond + ((impossible-filename? fragment) + ((handle-not-found) (make-pathname "/" current-path))) + ((directory? full-path) + (apply-access-file + full-path + (lambda () + (if (null? remaining-path) + (redirect-directory-root (make-pathname "/" current-path)) + ;; Ignore empty path components like most + ;; webservers do. It's slightly broken but + ;; enough scripts generate bad URIs that it's + ;; a useful thing to do. (maybe we shouldn't?) + (let lp ((remaining-path remaining-path)) + (cond + ((null? remaining-path) + (process-directory current-path)) + ((string=? "" (car remaining-path)) + (lp (cdr remaining-path))) + (else + (process-entry current-path + (car remaining-path) + (cdr remaining-path))))))))) + ((file-exists? full-path) + (parameterize ((current-pathinfo remaining-path) + (current-file (make-pathname "/" current-path))) + ((handle-file) (current-file)))) ;; hmm, not too useful + (else ((handle-not-found) (make-pathname "/" current-path)))))) + +;; Determine the vhost and port to use. This follows RFC 2616, section 5.2: +;; If request URL is absolute, use that. Otherwise, look at the Host header. +;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of +;; RFC 2616. If no host line is present, it returns the default host +;; for HTTP/1.0. +(define (determine-vhost req) + (let* ((uri (request-uri req)) + (host-header (header-value 'host (request-headers req)))) + (if (and (= (request-major req) 1) + (>= (request-minor req) 1) + (not host-header)) + #f + (or (and-let* ((host (uri-host uri)) + (port (uri-port uri))) + (cons host port)) + host-header + (cons (default-host) (server-port)))))) + +;; Make the request uri a full uri including the host and port +(define (normalize-uri req) + (let ((uri (request-uri req))) + (if (absolute-uri? uri) + uri + (let ((host&port (determine-vhost req)) + (scheme (if (secure-connection?) 'https 'http))) + (update-uri uri scheme: scheme + host: (and host&port (car host&port)) + port: (and host&port (cdr host&port))))))) + +(define request-restarter (make-parameter #f)) ; Internal parameter + +(define (restart-request req) + (debug! "Restarting request from ~A (with uri: ~A)" + (remote-address) (request-uri req)) + ((request-restarter) req (request-restarter))) + +(define (determine-remote-address-with-trusted-proxies req) + ;; If the remote end is untrusted, that's the remote address. If it + ;; is trusted, see for whom it forwarded the request and loop. Take + ;; care to stop on a trusted host if there are no more forwarded-for + ;; entries (a request may originate from a trusted host). + (let lp ((address-chain (cons (remote-address) + (reverse + (header-values 'x-forwarded-for + (request-headers req)))))) + (if (and (member (car address-chain) (trusted-proxies)) + (not (null? (cdr address-chain)))) + (lp (cdr address-chain)) + (car address-chain)))) + +(define (handle-incoming-request compiled-vhost-map in out) + (handle-exceptions exn ; This should probably be more fine-grained + (let ((chain (with-output-to-string print-call-chain))) + (close-input-port in) + (close-output-port out) + (debug! "~A" (build-error-message exn chain #t)) + #f) ; Do not keep going + (receive (req cont) + (call/cc (lambda (c) (values (read-request in) c))) + (and req ; No request? Then the connection was closed. Don't keep going. + (parameterize ((remote-address + (determine-remote-address-with-trusted-proxies req)) + (current-request + (update-request req uri: (normalize-uri req))) + (current-response + (make-response + port: out + headers: (intarweb:headers + `((content-type text/html) + (server ,(server-software)))))) + (request-restarter cont)) + (debug! "Handling request from ~A" (remote-address)) + (handle-exceptions exn + (begin + ((handle-exception) exn + (with-output-to-string print-call-chain)) + #f) ; Do not keep going + (let ((host (uri-host (request-uri (current-request))))) + (if (and host (uri-path-absolute? (request-uri (current-request)))) + (let ((ir&handler + (assoc host compiled-vhost-map + (lambda (host ir) + (irregex-match ir host))))) + (if ir&handler + ((cdr ir&handler) + (lambda () + (process-entry + "" "" + (cdr (uri-path (request-uri + (current-request))))))) + ;; Is this ok? + ((handle-not-found) + (uri-path (request-uri (current-request)))))) + ;; No host or non-absolute URI in the request is an error. + (send-status 'bad-request + (conc "<p>Your client sent a request that " + "the server did not understand</p>"))) + (unless (##sys#slot out 8) ;; port-closed? + (flush-output out)) + (handle-another-request?)))))))) ; Keep going? + +(define (htmlize str) + (string-translate* str '(("<" . "<") (">" . ">") + ("\"" . """) ("'" . "'") ("&" . "&")))) + +;; Do we want this here? +(unless (eq? (build-platform) 'msvc) + (set-signal-handler! signal/int (lambda (sig) (exit 1)))) + +(define (switch-user/group user group) + (when group ; group first, since only superuser can switch groups + (let ((ginfo (group-information group))) + (unless ginfo + (error "Group does not exist" group)) + (set! (current-group-id) (list-ref ginfo 2)))) + (when user + (let ((uinfo (user-information user))) + (unless uinfo + (error "User does not exist" user)) + (set-environment-variable! "HOME" (list-ref uinfo 5)) + (initialize-groups user (list-ref uinfo 3)) + (unless group ; Already changed to target group? + (set! (current-group-id) (list-ref uinfo 3))) + (set! (current-user-id) (list-ref uinfo 2))))) + +(define (mutex-update! m op) + (dynamic-wind + (lambda () (mutex-lock! m)) + (lambda () (mutex-specific-set! m (op (mutex-specific m)))) + (lambda () (mutex-unlock! m)))) + +(define (make-mutex/value name value) + (let ((m (make-mutex name))) + (mutex-specific-set! m value) + m)) + +;; Check whether the mutex has the correct state. If not, wait for a condition +;; and try again +(define (mutex-wait! m ok? condition) + (let retry () + (mutex-lock! m) + (if (ok? (mutex-specific m)) + (mutex-unlock! m) + (begin (mutex-unlock! m condition) (retry))))) + +;; Imports from the openssl egg, if available +(define (dynamic-import module symbol default) + (handle-exceptions _ default (eval `(let () (import ,module) ,symbol)))) + +(define ssl-port? + (dynamic-import 'openssl 'ssl-port? (lambda (v) #f))) + +(define ssl-port->tcp-port + (dynamic-import + 'openssl 'ssl-port->tcp-port + (lambda (v) (error 'ssl-port->tcp-port "Expected an SSL port" v)))) + +(define (ssl-or-tcp-addresses p) + (tcp-addresses (if (ssl-port? p) (ssl-port->tcp-port p) p))) + +(define-inline (spiffy-thread-start! thunk) + (thread-start! (make-thread thunk (gensym 'spiffy)))) + +(define (accept-loop listener accept #!optional (addresses ssl-or-tcp-addresses)) + (let ((thread-count (make-mutex/value 'thread-count 0)) + (thread-stopped! (make-condition-variable 'thread-stopped!)) + (exn-message (condition-property-accessor 'exn 'message "(no message)")) + (compiled-vhost-map + (map (lambda (irregex&handler) + (cons (irregex (car irregex&handler) 'i) + (cdr irregex&handler))) + (vhost-map)))) + (let accept-next-connection () + ;; Wait until we have a free connection slot + (mutex-wait! thread-count + (lambda (count) (< count (max-connections))) + thread-stopped!) + (handle-exceptions ; Catch errors during TCP/SSL handshake + e (debug! "Connection handshake error: ~S" (exn-message e)) + (let*-values (((in out) (accept listener)) + ((local remote) (addresses in))) + (mutex-update! thread-count add1) + (spiffy-thread-start! + (lambda () + (debug! "Incoming request from ~A" remote) + ;; thread-count _must_ be updated, so trap all exns + (handle-exceptions + e (debug! "Uncaught exception: ~S (SHOULD NOT HAPPEN!)" + (exn-message e)) + ;; Most of these won't change during the session. + ;; Some may be refined using info from headers after parsing + (parameterize ((remote-address remote) ; Initial value + (local-address local) + ;; Believe the user when (s)he says it's a + ;; secure connection. Otherwise try to + ;; detect it by checking for an SSL port. + (secure-connection? + (or (secure-connection?) (ssl-port? in))) + (handle-another-request? #t) + (load-verbose #f)) + (let handle-next-request () + (when (and (handle-incoming-request + compiled-vhost-map in out) + (not (port-closed? in)) + (not (port-closed? out))) + (debug! "Kept alive") + (handle-next-request))) + (debug! "Closing off") + (close-input-port in) + (close-output-port out))) + (mutex-update! thread-count sub1) + ;; Wake up the accepting thread if it's asleep + (condition-variable-signal! thread-stopped!))))) + (accept-next-connection)))) + +(define (start-server #!key + (port (server-port)) + (bind-address (server-bind-address)) + (listen tcp-listen) + (accept tcp-accept) + (addresses ssl-or-tcp-addresses)) + (let ((listener (listen port 100 bind-address))) + ;; Drop privileges ASAP, now the TCP listener has been created + (switch-user/group (spiffy-user) (spiffy-group)) + ;; Make these parameters actual (start-server arg might override it) + (parameterize ((server-port port) + (server-bind-address bind-address)) + (accept-loop listener accept addresses)))) + +) |