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
[ ] [ 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

View File

@ -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) ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;