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

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