| 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 | )
|
|---|
