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 ;

224
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,53 +236,70 @@ http.server.dispatchers db.tuples ;
] with-db ] with-db
] unit-test ] unit-test
[ ] [ : test-with-dispatcher ( dispatcher quot -- )
<dispatcher> '[
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>
add-quit-action add-quit-action
<dispatcher> <dispatcher>
"vocab:http/test" <static> >>default "vocab:http/test" <static> >>default
"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 [ t ] [
] unit-test
[ t ] [
"vocab:http/test/foo.html" ascii file-contents "vocab:http/test/foo.html" ascii file-contents
"http://localhost/nested/foo.html" add-addr http-get nip = "http://localhost/nested/foo.html" add-addr http-get nip =
] unit-test ] unit-test
[ "http://localhost/redirect-loop" add-addr http-get nip ] [ "http://localhost/redirect-loop" add-addr http-get nip ]
[ too-many-redirects? ] must-fail-with [ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [ [ "Goodbye" ] [
"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 [ "Goodbye" ] [
] unit-test
[ "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 -- ? )
<dispatcher> {
[ download-failed? ]
[ response>> response? ]
[ response>> code>> 404 = ]
} 1&& ;
<dispatcher>
<action> <protected> <action> <protected>
"Test" <login-realm> "Test" <login-realm>
<sessions> <sessions>
@ -302,41 +308,31 @@ 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 ! This should give a 404 not an infinite redirect loop
] unit-test [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
: 404? ( response -- ? ) ! This should give a 404 not an infinite redirect loop
{ [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
[ download-failed? ]
[ response>> response? ]
[ response>> code>> 404 = ]
} 1&& ;
! This should give a 404 not an infinite redirect loop [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop ] test-with-db-persistence
[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test <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 [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
] 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
@ -344,8 +340,10 @@ furnace furnace.conversations ;
SYMBOL: a SYMBOL: a
[ ] [ : test-a ( xml -- value )
<dispatcher> string>xml body>> "input" deep-tag-named "value" attr ;
<dispatcher>
<action> <action>
[ a get-global "a" set-value ] >>init [ a get-global "a" set-value ] >>init
[ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display [ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
@ -355,72 +353,69 @@ SYMBOL: a
<sessions> <sessions>
>>default >>default
add-quit-action add-quit-action
test-db <db-persistence> test-db <db-persistence> [
test-httpd 3 a set-global
] unit-test
3 a set-global [ "3" ] [
: test-a ( xml -- value )
string>xml body>> "input" deep-tag-named "value" attr ;
[ "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
value>> "session-id" set test-a value>> "session-id" set test-a
] unit-test ] unit-test
[ "4" ] [ [ "4" ] [
[ [
"4" "a" ,, "4" "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
] unit-test http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test [ 4 ] [ a get-global ] unit-test
! Test flash scope ! Test flash scope
[ "xyz" ] [ [ "xyz" ] [
[ [
"xyz" "a" ,, "xyz" "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
] unit-test http-request nip test-a
] 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
] unit-test
! Test a corner case with static responder ! Test a corner case with static responder
[ ] [ <dispatcher>
<dispatcher>
add-quit-action add-quit-action
"vocab:http/test/foo.html" <static> >>default "vocab:http/test/foo.html" <static> >>default [
test-httpd [ t ] [
] unit-test
[ 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 =
] unit-test ] unit-test
[ ] [ 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>
[ "b" <temporary-redirect> ] >>submit [ "b" <temporary-redirect> ] >>submit
@ -430,40 +425,37 @@ 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
! Check that download throws errors (reported by Chris Double) ! Check that download throws errors (reported by Chris Double)
[ [
[ [
"http://localhost/tweet_my_twat" add-addr download "http://localhost/tweet_my_twat" add-addr download
] with-temp-directory ] with-temp-directory
] must-fail ] must-fail
[ ] [ 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
] test-with-dispatcher
! Check that just closing the socket without sending anything works ! Check that just closing the socket without sending anything works
[ ] [ <dispatcher>
<dispatcher> add-quit-action [
add-quit-action [ ] [ "addr" get binary [ ] with-client ] unit-test
test-httpd
] unit-test
[ ] [ "addr" get binary [ ] with-client ] unit-test [ ] [ stop-test-httpd ] unit-test
[ ] [ stop-test-httpd ] unit-test ] test-with-dispatcher