More robust server tests

extra/concurrency/distributed/distributed-tests.factor

@@ -13,8 +13,6 @@ concurrency.messaging continuations accessors prettyprint ;
 
 [ ] [ test-node dup (start-node) ] unit-test
 
-[ ] [ 1000 sleep ] unit-test
-
 [ ] [
     [
         receive first2 >r 3 + r> send
@@ -30,6 +28,4 @@ concurrency.messaging continuations accessors prettyprint ;
     receive
 ] unit-test
 
-[ ] [ 1000 sleep ] unit-test
-
 [ ] [ test-node stop-node ] unit-test

extra/concurrency/distributed/distributed.factor

@@ -12,16 +12,15 @@ SYMBOL: local-node
     deserialize
     [ first2 get-process send ] [ stop-server ] if* ;
 
+: <node-server> ( addrspec -- threaded-server )
+    <threaded-server>
+        swap >>insecure
+        binary >>encoding
+        "concurrency.distributed" >>name
+        [ handle-node-client ] >>handler ;
+
 : (start-node) ( addrspec addrspec -- )
-    local-node set-global
-    [
-        <threaded-server>
-            swap >>insecure
-            binary >>encoding
-            "concurrency.distributed" >>name
-            [ handle-node-client ] >>handler
-        start-server
-    ] curry "Distributed concurrency server" spawn drop ;
+    local-node set-global <node-server> start-server* ;
 
 : start-node ( port -- )
     host-name over <inet> (start-node) ;

extra/http/http-tests.factor

@@ -190,6 +190,13 @@ test-db [
     init-furnace-tables
 ] with-db
 
+: test-httpd ( -- )
+    #! Return as soon as server is running.
+    <http-server>
+        1237 >>insecure
+        f >>secure
+    start-server* ;
+
 [ ] [
     [
         <dispatcher>
@@ -202,12 +209,10 @@ test-db [
             "redirect-loop" add-responder
         main-responder set
 
-        [ 1237 httpd ] "HTTPD test" spawn drop
+        test-httpd
     ] with-scope
 ] unit-test
 
-[ ] [ 100 sleep ] unit-test
-
 [ t ] [
     "resource:extra/http/test/foo.html" ascii file-contents
     "http://localhost:1237/nested/foo.html" http-get nip ascii decode =
@@ -235,12 +240,10 @@ test-db [
         test-db <db-persistence>
         main-responder set
 
-        [ 1237 httpd ] "HTTPD test" spawn drop
+        test-httpd
     ] with-scope
 ] unit-test
 
-[ ] [ 100 sleep ] unit-test
-
 : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 
 ! This should give a 404 not an infinite redirect loop
@@ -262,12 +265,10 @@ test-db [
         test-db <db-persistence>
         main-responder set
 
-        [ 1237 httpd ] "HTTPD test" spawn drop
+        test-httpd
     ] with-scope
 ] unit-test
 
-[ ] [ 100 sleep ] unit-test
-
 [ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
 
 [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
@@ -293,12 +294,10 @@ SYMBOL: a
         test-db <db-persistence>
         main-responder set
 
-        [ 1237 httpd ] "HTTPD test" spawn drop
+        test-httpd
     ] with-scope
 ] unit-test
 
-[ ] [ 100 sleep ] unit-test
-
 3 a set-global
 
 : test-a string>xml "input" tag-named "value" swap at ;

extra/io/servers/connection/connection-tests.factor

@@ -29,18 +29,22 @@ concurrency.promises io.encodings.ascii io threads calendar ;
 
 [ ] [ <promise> "p" set ] unit-test
 
+[ ] [
+    <threaded-server>
+        5 >>max-connections
+        1237 >>insecure
+        [ "Hello world." write stop-server ] >>handler
+    "server" set
+] unit-test
+
 [ ] [
     [
-        <threaded-server>
-            5 >>max-connections
-            1237 >>insecure
-            [ "Hello world." write stop-server ] >>handler
-        start-server
+        "server" get start-server
         t "p" get fulfill
     ] in-thread
 ] unit-test
 
-[ ] [ 100 sleep ] unit-test
+[ ] [ "server" get wait-for-server ] unit-test
 
 [ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
 

extra/io/servers/connection/connection.factor

@@ -6,7 +6,8 @@ quotations combinators logging calendar assocs
 fry accessors arrays io io.sockets io.encodings.ascii
 io.sockets.secure io.files io.streams.duplex io.timeouts
 io.encodings threads concurrency.combinators
-concurrency.semaphores combinators.short-circuit ;
+concurrency.semaphores concurrency.flags
+combinators.short-circuit ;
 IN: io.servers.connection
 
 TUPLE: threaded-server
@@ -18,7 +19,8 @@ max-connections
 semaphore
 timeout
 encoding
-handler ;
+handler
+ready ;
 
 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
 
@@ -31,7 +33,8 @@ handler ;
         1 minutes >>timeout
         V{ } clone >>sockets
         <secure-config> >>secure-config
-        [ "No handler quotation" throw ] >>handler ; inline
+        [ "No handler quotation" throw ] >>handler
+        <flag> >>ready ; inline
 
 : <threaded-server> ( -- threaded-server )
     threaded-server new-threaded-server ;
@@ -86,11 +89,13 @@ M: threaded-server handle-client* handler>> call ;
         if*
     ] [ accept-loop ] bi ; inline
 
-: start-accept-loop ( server -- )
+: started-accept-loop ( server -- )
+    threaded-server get
+    [ sockets>> push ] [ ready>> raise-flag ] bi ;
+
+: start-accept-loop ( addrspec -- )
     threaded-server get encoding>> <server>
-    [ threaded-server get sockets>> push ]
-    [ [ accept-loop ] with-disposal ]
-    bi ;
+    [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
 
 \ start-accept-loop ERROR add-error-logging
 
@@ -115,6 +120,14 @@ PRIVATE>
         ] with-variable
     ] with-secure-context ;
 
+: wait-for-server ( threaded-server -- )
+    ready>> wait-for-flag ;
+
+: start-server* ( threaded-server -- )
+    [ [ start-server ] curry "Threaded server" spawn drop ]
+    [ wait-for-server ]
+    bi ;
+
 : stop-server ( -- )
     threaded-server get [ f ] change-sockets drop dispose-each ;