Ticket #502: 502.txt

File 502.txt, 2.1 KB (added by Jim Ursetto, 13 years ago)
Line 
1Index: spiffy.scm
2===================================================================
3--- spiffy.scm  (revision 22712)
4+++ spiffy.scm  (working copy)
5@@ -524,7 +524,11 @@
6 (define (ssl-port->tcp-port p)
7   (if (ssl-port? p) (##sys#slot p 11) (error "Expected an SSL port")))
8 
9-(define (accept-loop listener accept)
10+(define (ssl-or-tcp-addresses p)
11+  (tcp-addresses
12+   (if (ssl-port? p) (ssl-port->tcp-port p) p)))
13+
14+(define (accept-loop listener accept #!optional (addresses ssl-or-tcp-addresses))
15   (let ((thread-count (make-mutex/value 'thread-count 0))
16         (thread-stopped! (make-condition-variable 'thread-stopped!))
17         (exn-message (condition-property-accessor 'exn 'message "(no message)"))
18@@ -539,10 +543,7 @@
19       (handle-exceptions       ; Catch errors during TCP/SSL handshake
20           e (debug! "Connection handshake error: ~S" (exn-message e))
21           (let*-values (((in out)       (accept listener))
22-                        ((local remote) (tcp-addresses
23-                                         (if (ssl-port? in)
24-                                             (ssl-port->tcp-port in)
25-                                             in))))
26+                        ((local remote) (addresses in)))
27             (debug! "Incoming request from ~A" remote)
28             (mutex-update! thread-count add1)
29             (thread-start!
30@@ -580,7 +581,8 @@
31                       (ssl-keyfile (server-ssl-keyfile)) ; Deprecated
32                       (bind-address (server-bind-address))
33                       (listen tcp-listen)
34-                      (accept tcp-accept))
35+                      (accept tcp-accept)
36+                      (addresses ssl-or-tcp-addresses))
37   (when (or ssl-client-context ssl-pemfile ssl-keyfile)
38     (error (conc "ssl-client-context, ssl-pemfile and ssl-keyfile are no "
39                  "longer directly supported by start-server in order to make "
40@@ -592,6 +594,6 @@
41     ;; Make these parameters actual (start-server arg might override it)
42     (parameterize ((server-port port)
43                    (server-bind-address bind-address))
44-      (accept-loop listener accept))))
45+      (accept-loop listener accept addresses))))
46 
47 )