steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

furnace.db: db-persistence needs a dispose word that delegates to its pool slot 

tests in http.tests refactored using "with-words" so that they always
dispose any db-persistence instances they create.
db4
Björn Lindqvist 2014-09-22 23:47:48 +02:00 committed by John Benediktsson
parent 3ca2801d33
commit 1824680ad1
2 changed files with 167 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/furnace/db/db.factor
View File

@ -4,10 +4,10 @@ USING: kernel accessors continuations namespaces destructors
db db.private db.pools io.pools http.server http.server.filters ; db db.private db.pools io.pools http.server http.server.filters ;
IN: furnace.db IN: furnace.db
TUPLE: db-persistence < filter-responder pool ; TUPLE: db-persistence < filter-responder pool disposed ;
: <db-persistence> ( responder db -- responder' ) : <db-persistence> ( responder db -- responder' )
<db-pool> db-persistence boa ; <db-pool> f db-persistence boa ;
M: db-persistence call-responder* M: db-persistence call-responder*
[ [
@ -15,3 +15,5 @@ M: db-persistence call-responder*
[ return-connection-later ] [ drop db-connection set ] 2bi [ return-connection-later ] [ drop db-connection set ] 2bi
] ]
[ call-next-method ] bi ; [ call-next-method ] bi ;
M: db-persistence dispose* pool>> dispose ;

138
basis/http/http-tests.factor
View File

@ -1,5 +1,5 @@
USING: http http.server http.client http.client.private tools.test USING: destructors http http.server http.client http.client.private tools.test
multiline io.streams.string io.encodings.utf8 io.encodings.8-bit multiline fry io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string io.encodings.ascii kernel io.encodings.binary io.encodings.string io.encodings.ascii kernel
arrays splitting sequences assocs io.sockets db db.sqlite make arrays splitting sequences assocs io.sockets db db.sqlite make
continuations urls hashtables accessors namespaces xml.data continuations urls hashtables accessors namespaces xml.data
@ -221,17 +221,6 @@ http.server.dispatchers db.tuples ;
: test-db ( -- db ) test-db-file <sqlite-db> ; : test-db ( -- db ) test-db-file <sqlite-db> ;
: test-httpd ( responder -- )
[
main-responder set
<http-server>
0 >>insecure
f >>secure
start-server
threaded-server set
server-addrs random
] with-scope "addr" set ;
: add-addr ( url -- url' ) : add-addr ( url -- url' )
>url clone "addr" get set-url-addr ; >url clone "addr" get set-url-addr ;
@ -247,7 +236,22 @@ http.server.dispatchers db.tuples ;
] with-db ] with-db
] unit-test ] unit-test
[ ] [ : test-with-dispatcher ( dispatcher quot -- )
'[
main-responder set
<http-server> 0 >>insecure f >>secure
[
server-addrs random "addr" set @
] with-threaded-server
] with-scope ; inline
USING: locals ;
:: test-with-db-persistence ( db-persistence quot -- )
db-persistence [
quot test-with-dispatcher
] with-disposal ; inline
<dispatcher> <dispatcher>
add-quit-action add-quit-action
<dispatcher> <dispatcher>
@ -255,10 +259,7 @@ http.server.dispatchers db.tuples ;
"nested" add-responder "nested" add-responder
<action> <action>
[ URL" redirect-loop" <temporary-redirect> ] >>display [ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder "redirect-loop" add-responder [
test-httpd
] unit-test
[ t ] [ [ t ] [
"vocab:http/test/foo.html" ascii file-contents "vocab:http/test/foo.html" ascii file-contents
@ -272,27 +273,32 @@ http.server.dispatchers db.tuples ;
"http://localhost/quit" add-addr http-get nip "http://localhost/quit" add-addr http-get nip
] unit-test ] unit-test
] test-with-dispatcher
! HTTP client redirect bug ! HTTP client redirect bug
[ ] [
<dispatcher> <dispatcher>
add-quit-action add-quit-action
<action> [ "quit" <temporary-redirect> ] >>display <action> [ "quit" <temporary-redirect> ] >>display
"redirect" add-responder "redirect" add-responder [
test-httpd
] unit-test
[ "Goodbye" ] [ [ "Goodbye" ] [
"http://localhost/redirect" add-addr http-get nip "http://localhost/redirect" add-addr http-get nip
] unit-test ] unit-test
[ ] [ [ ] [
[ stop-test-httpd ] ignore-errors [ stop-test-httpd ] ignore-errors
] unit-test ] unit-test
] test-with-dispatcher
! Dispatcher bugs ! Dispatcher bugs
[ ] [ : 404? ( response -- ? )
{
[ download-failed? ]
[ response>> response? ]
[ response>> code>> 404 = ]
} 1&& ;
<dispatcher> <dispatcher>
<action> <protected> <action> <protected>
"Test" <login-realm> "Test" <login-realm>
@ -302,17 +308,7 @@ http.server.dispatchers db.tuples ;
<dispatcher> <dispatcher>
<action> "" add-responder <action> "" add-responder
"d" add-responder "d" add-responder
test-db <db-persistence> test-db <db-persistence> [
test-httpd
] unit-test
: 404? ( response -- ? )
{
[ download-failed? ]
[ response>> response? ]
[ response>> code>> 404 = ]
} 1&& ;
! This should give a 404 not an infinite redirect loop ! This should give a 404 not an infinite redirect loop
[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
@ -322,29 +318,31 @@ http.server.dispatchers db.tuples ;
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
[ ] [ ] test-with-db-persistence
<dispatcher> <dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
"Test" <login-realm> "Test" <login-realm>
<sessions> <sessions>
"" add-responder "" add-responder
add-quit-action add-quit-action
test-db <db-persistence> test-db <db-persistence> [
test-httpd
] unit-test
[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
] test-with-db-persistence
USING: html.components html.forms USING: html.components html.forms
xml xml.traversal validators xml xml.traversal validators
furnace furnace.conversations ; furnace furnace.conversations ;
SYMBOL: a SYMBOL: a
[ ] [ : test-a ( xml -- value )
string>xml body>> "input" deep-tag-named "value" attr ;
<dispatcher> <dispatcher>
<action> <action>
[ a get-global "a" set-value ] >>init [ a get-global "a" set-value ] >>init
@ -355,16 +353,10 @@ SYMBOL: a
<sessions> <sessions>
>>default >>default
add-quit-action add-quit-action
test-db <db-persistence> test-db <db-persistence> [
test-httpd
] unit-test
3 a set-global 3 a set-global
: test-a ( xml -- value )
string>xml body>> "input" deep-tag-named "value" attr ;
[ "3" ] [ [ "3" ] [
"http://localhost/" add-addr http-get "http://localhost/" add-addr http-get
swap dup cookies>> "cookies" set session-id-key get-cookie swap dup cookies>> "cookies" set session-id-key get-cookie
@ -377,7 +369,8 @@ SYMBOL: a
"http://localhost" add-addr "__u" ,, "http://localhost" add-addr "__u" ,,
"session-id" get session-id-key ,, "session-id" get session-id-key ,,
] H{ } make ] H{ } make
"http://localhost/" add-addr <post-request> "cookies" get >>cookies http-request nip test-a "http://localhost/" add-addr <post-request> "cookies" get >>cookies
http-request nip test-a
] unit-test ] unit-test
[ 4 ] [ a get-global ] unit-test [ 4 ] [ a get-global ] unit-test
@ -389,28 +382,29 @@ SYMBOL: a
"http://localhost" add-addr "__u" ,, "http://localhost" add-addr "__u" ,,
"session-id" get session-id-key ,, "session-id" get session-id-key ,,
] H{ } make ] H{ } make
"http://localhost/" add-addr <post-request> "cookies" get >>cookies http-request nip test-a "http://localhost/" add-addr <post-request> "cookies" get >>cookies
http-request nip test-a
] unit-test ] unit-test
[ 4 ] [ a get-global ] unit-test [ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
] test-with-db-persistence
! Test cloning ! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
! Test basic auth ! Test basic auth
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test [ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [
<request> "Aladdin" "open sesame" set-basic-auth "Authorization" header
! Test a corner case with static responder
[ ] [
<dispatcher>
add-quit-action
"vocab:http/test/foo.html" <static> >>default
test-httpd
] unit-test ] unit-test
! Test a corner case with static responder
<dispatcher>
add-quit-action
"vocab:http/test/foo.html" <static> >>default [
[ t ] [ [ t ] [
"http://localhost/" add-addr http-get nip "http://localhost/" add-addr http-get nip
"vocab:http/test/foo.html" ascii file-contents = "vocab:http/test/foo.html" ascii file-contents =
@ -418,8 +412,9 @@ SYMBOL: a
[ ] [ stop-test-httpd ] unit-test [ ] [ stop-test-httpd ] unit-test
] test-with-dispatcher
! Check behavior of 307 redirect (reported by Chris Double) ! Check behavior of 307 redirect (reported by Chris Double)
[ ] [
<dispatcher> <dispatcher>
add-quit-action add-quit-action
<action> <action>
@ -430,9 +425,7 @@ SYMBOL: a
request get post-data>> data>> "data" = request get post-data>> data>> "data" =
[ "OK" "text/plain" <content> ] [ "OOPS" throw ] if [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
] >>submit ] >>submit
"b" add-responder "b" add-responder [
test-httpd
] unit-test
[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test [ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
@ -445,25 +438,24 @@ SYMBOL: a
[ ] [ stop-test-httpd ] unit-test [ ] [ stop-test-httpd ] unit-test
] test-with-dispatcher
! Check that index.fhtml works ! Check that index.fhtml works
[ ] [
<dispatcher> <dispatcher>
"resource:basis/http/test/" <static> enable-fhtml >>default "resource:basis/http/test/" <static> enable-fhtml >>default
add-quit-action add-quit-action [
test-httpd
] unit-test
[ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test [ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
[ ] [ stop-test-httpd ] unit-test [ ] [ stop-test-httpd ] unit-test
! Check that just closing the socket without sending anything works ] test-with-dispatcher
[ ] [
<dispatcher>
add-quit-action
test-httpd
] unit-test
! Check that just closing the socket without sending anything works
<dispatcher>
add-quit-action [
[ ] [ "addr" get binary [ ] with-client ] unit-test [ ] [ "addr" get binary [ ] with-client ] unit-test
[ ] [ stop-test-httpd ] unit-test [ ] [ stop-test-httpd ] unit-test
] test-with-dispatcher