More robust server tests

db4
slava 2008-06-25 16:58:19 -05:00
parent bc5c784016
commit 45bc2a0a02
5 changed files with 49 additions and 38 deletions

View File

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

View File

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

View File

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

View File

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

View File

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