| 1 | Index: 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 | ) |
|---|
