diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index fbe5421cea..6866a9d4a7 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -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