Make secure-context persist longer than a millisecond when a server gets started.
parent
546b81b697
commit
b03268f047
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue