More robust server tests
parent
bc5c784016
commit
45bc2a0a02
|
@ -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
|
||||||
|
|
|
@ -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) ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue