Make secure-context persist longer than a millisecond when a server gets started.

db4
Doug Coleman 2010-09-27 18:57:14 -05:00
parent 546b81b697
commit b03268f047
1 changed files with 38 additions and 30 deletions

View File

@ -22,7 +22,8 @@ semaphore
timeout
encoding
handler
server-stopped ;
server-stopped
secure-context ;
SYMBOL: running-servers
running-servers [ HS{ } clone ] initialize
@ -131,14 +132,24 @@ M: threaded-server handle-client* handler>> call( -- ) ;
[ (accept-connection) ]
if* ;
: with-existing-secure-context ( threaded-server quot -- )
[ secure-context>> secure-context ] dip with-variable ; inline
: accept-loop ( server -- )
[ accept-connection ] [ accept-loop ] bi ;
: start-accept-loop ( server -- ) accept-loop ;
: start-accept-loop ( threaded-server server -- )
'[ _ accept-loop ] with-existing-secure-context ;
\ start-accept-loop NOTICE add-error-logging
: create-secure-context ( threaded-server -- threaded-server )
dup secure>> [
dup secure-config>> <secure-context> >>secure-context
] when ;
: init-server ( threaded-server -- threaded-server )
create-secure-context
<flag> >>server-stopped
dup semaphore>> [
dup max-connections>> [
@ -153,48 +164,45 @@ ERROR: no-ports-configured threaded-server ;
'[ [ _ <server> |dispose ] map ] with-destructors ;
: set-servers ( threaded-server -- threaded-server )
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
>>servers ;
dup [
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
>>servers
] with-existing-secure-context ;
: server-thread-name ( threaded-server addrspec -- string )
[ name>> ] [ addr>> present ] bi* " server on " glue ;
: (start-server) ( threaded-server -- )
init-server
dup threaded-server [
[ ] [ name>> ] bi
[
set-servers
dup add-running-server
dup servers>>
[
[ nip '[ _ [ start-accept-loop ] with-disposal ] ]
[ server-thread-name ] 2bi spawn drop
] with each
] with-logging
] with-variable ;
PRIVATE>
: start-server ( threaded-server -- threaded-server )
#! Only create a secure-context if we want to listen on
#! a secure port, otherwise start-server won't work at
#! all if SSL is not available.
dup dup secure>> [
dup secure-config>> [
(start-server)
] with-secure-context
] [
(start-server)
] if ;
init-server
[
dup threaded-server [
[ ] [ name>> ] bi
[
set-servers
dup add-running-server
dup servers>>
[
[ '[ _ _ [ start-accept-loop ] with-disposal ] ]
[ server-thread-name ] 2bi spawn drop
] with each
] with-logging
] with-variable
] keep ;
: server-running? ( threaded-server -- ? )
server-stopped>> [ value>> not ] [ f ] if* ;
: stop-server ( threaded-server -- )
dup server-running? [
[ [ f ] change-servers drop dispose-each ]
[ remove-running-server ]
[
[
[ secure-context>> [ &dispose drop ] when* ]
[ [ f ] change-servers drop dispose-each ] bi
] with-destructors
]
[ server-stopped>> raise-flag ] tri
] [
drop