From 1824680ad1c3cdf191b76e10cf19457902103b82 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Bj=C3=B6rn=20Lindqvist?= Date: Mon, 22 Sep 2014 23:47:48 +0200 Subject: [PATCH] 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. --- basis/furnace/db/db.factor | 6 +- basis/http/http-tests.factor | 344 +++++++++++++++++------------------ 2 files changed, 172 insertions(+), 178 deletions(-) diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor index d771d1d2d7..c09be983bb 100644 --- a/basis/furnace/db/db.factor +++ b/basis/furnace/db/db.factor @@ -4,10 +4,10 @@ USING: kernel accessors continuations namespaces destructors db db.private db.pools io.pools http.server http.server.filters ; IN: furnace.db -TUPLE: db-persistence < filter-responder pool ; +TUPLE: db-persistence < filter-responder pool disposed ; : ( responder db -- responder' ) - db-persistence boa ; + f db-persistence boa ; M: db-persistence call-responder* [ @@ -15,3 +15,5 @@ M: db-persistence call-responder* [ return-connection-later ] [ drop db-connection set ] 2bi ] [ call-next-method ] bi ; + +M: db-persistence dispose* pool>> dispose ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index d9a4e36a57..94a0fa7728 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,5 +1,5 @@ -USING: http http.server http.client http.client.private tools.test -multiline io.streams.string io.encodings.utf8 io.encodings.8-bit +USING: destructors http http.server http.client http.client.private tools.test +multiline fry io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db db.sqlite make continuations urls hashtables accessors namespaces xml.data @@ -221,17 +221,6 @@ http.server.dispatchers db.tuples ; : test-db ( -- db ) test-db-file ; -: test-httpd ( responder -- ) - [ - main-responder set - - 0 >>insecure - f >>secure - start-server - threaded-server set - server-addrs random - ] with-scope "addr" set ; - : add-addr ( url -- url' ) >url clone "addr" get set-url-addr ; @@ -247,66 +236,62 @@ http.server.dispatchers db.tuples ; ] with-db ] unit-test -[ ] [ +: test-with-dispatcher ( dispatcher quot -- ) + '[ + main-responder set + 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 + + + add-quit-action - add-quit-action - - "vocab:http/test" >>default - "nested" add-responder - - [ URL" redirect-loop" ] >>display - "redirect-loop" add-responder - - test-httpd -] unit-test + "vocab:http/test" >>default + "nested" add-responder + + [ URL" redirect-loop" ] >>display + "redirect-loop" add-responder [ -[ t ] [ - "vocab:http/test/foo.html" ascii file-contents - "http://localhost/nested/foo.html" add-addr http-get nip = -] unit-test + [ t ] [ + "vocab:http/test/foo.html" ascii file-contents + "http://localhost/nested/foo.html" add-addr http-get nip = + ] unit-test -[ "http://localhost/redirect-loop" add-addr http-get nip ] -[ too-many-redirects? ] must-fail-with + [ "http://localhost/redirect-loop" add-addr http-get nip ] + [ too-many-redirects? ] must-fail-with -[ "Goodbye" ] [ - "http://localhost/quit" add-addr http-get nip -] unit-test + [ "Goodbye" ] [ + "http://localhost/quit" add-addr http-get nip + ] unit-test -! HTTP client redirect bug -[ ] [ - - add-quit-action - [ "quit" ] >>display - "redirect" add-responder +] test-with-dispatcher - test-httpd -] unit-test +! HTTP client redirect bug + + add-quit-action + [ "quit" ] >>display + "redirect" add-responder [ -[ "Goodbye" ] [ - "http://localhost/redirect" add-addr http-get nip -] unit-test + [ "Goodbye" ] [ + "http://localhost/redirect" add-addr http-get nip + ] unit-test + [ ] [ + [ stop-test-httpd ] ignore-errors + ] unit-test -[ ] [ - [ stop-test-httpd ] ignore-errors -] unit-test +] test-with-dispatcher ! Dispatcher bugs -[ ] [ - - - "Test" - - "" add-responder - add-quit-action - - "" add-responder - "d" add-responder - test-db - - test-httpd -] unit-test - : 404? ( response -- ? ) { [ download-failed? ] @@ -314,29 +299,40 @@ http.server.dispatchers db.tuples ; [ response>> code>> 404 = ] } 1&& ; -! This should give a 404 not an infinite redirect loop -[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with + + + "Test" + + "" add-responder + add-quit-action + + "" add-responder + "d" add-responder +test-db [ -! This should give a 404 not an infinite redirect loop -[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with + ! This should give a 404 not an infinite redirect loop + [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + ! This should give a 404 not an infinite redirect loop + [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with -[ ] [ - - [ [ "Hi" write ] "text/plain" ] >>display - "Test" - - "" add-responder - add-quit-action - test-db - - test-httpd -] unit-test + [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + +] test-with-db-persistence -[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test + + [ [ "Hi" write ] "text/plain" ] >>display + "Test" + + "" add-responder + add-quit-action +test-db [ -[ "Goodbye" ] [ "http://localhost/quit" 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 + +] test-with-db-persistence USING: html.components html.forms xml xml.traversal validators @@ -344,126 +340,122 @@ furnace furnace.conversations ; SYMBOL: a -[ ] [ - - - [ a get-global "a" set-value ] >>init - [ [ "" write "a" render "" write ] "text/html" ] >>display - [ { { "a" [ v-integer ] } } validate-params ] >>validate - [ "a" value a set-global URL" " ] >>submit - - - >>default - add-quit-action - test-db - - test-httpd -] unit-test - -3 a set-global - : test-a ( xml -- value ) string>xml body>> "input" deep-tag-named "value" attr ; -[ "3" ] [ - "http://localhost/" add-addr http-get - swap dup cookies>> "cookies" set session-id-key get-cookie - value>> "session-id" set test-a -] unit-test - -[ "4" ] [ - [ - "4" "a" ,, - "http://localhost" add-addr "__u" ,, - "session-id" get session-id-key ,, - ] H{ } make - "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a -] unit-test - -[ 4 ] [ a get-global ] unit-test - -! Test flash scope -[ "xyz" ] [ - [ - "xyz" "a" ,, - "http://localhost" add-addr "__u" ,, - "session-id" get session-id-key ,, - ] H{ } make - "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a -] unit-test - -[ 4 ] [ a get-global ] unit-test - -[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + + + [ a get-global "a" set-value ] >>init + [ [ "" write "a" render "" write ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action +test-db [ + + 3 a set-global + + [ "3" ] [ + "http://localhost/" add-addr http-get + swap dup cookies>> "cookies" set session-id-key get-cookie + value>> "session-id" set test-a + ] unit-test + + [ "4" ] [ + [ + "4" "a" ,, + "http://localhost" add-addr "__u" ,, + "session-id" get session-id-key ,, + ] H{ } make + "http://localhost/" add-addr "cookies" get >>cookies + http-request nip test-a + ] unit-test + + [ 4 ] [ a get-global ] unit-test + + ! Test flash scope + [ "xyz" ] [ + [ + "xyz" "a" ,, + "http://localhost" add-addr "__u" ,, + "session-id" get session-id-key ,, + ] H{ } make + "http://localhost/" add-addr "cookies" get >>cookies + http-request nip test-a + ] unit-test + + [ 4 ] [ a get-global ] unit-test + + [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + +] test-with-db-persistence ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test ! Test basic auth -[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test +[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ + "Aladdin" "open sesame" set-basic-auth "Authorization" header +] unit-test ! Test a corner case with static responder -[ ] [ - - add-quit-action - "vocab:http/test/foo.html" >>default - test-httpd -] unit-test + + add-quit-action + "vocab:http/test/foo.html" >>default [ + [ t ] [ + "http://localhost/" add-addr http-get nip + "vocab:http/test/foo.html" ascii file-contents = + ] unit-test -[ t ] [ - "http://localhost/" add-addr http-get nip - "vocab:http/test/foo.html" ascii file-contents = -] unit-test + [ ] [ stop-test-httpd ] unit-test -[ ] [ stop-test-httpd ] unit-test +] test-with-dispatcher ! Check behavior of 307 redirect (reported by Chris Double) -[ ] [ - - add-quit-action - - [ "b" ] >>submit - "a" add-responder - - [ - request get post-data>> data>> "data" = - [ "OK" "text/plain" ] [ "OOPS" throw ] if - ] >>submit - "b" add-responder - test-httpd -] unit-test + + add-quit-action + + [ "b" ] >>submit + "a" add-responder + + [ + request get post-data>> data>> "data" = + [ "OK" "text/plain" ] [ "OOPS" throw ] if + ] >>submit + "b" add-responder [ -[ "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 - ] with-temp-directory -] must-fail + [ + "http://localhost/tweet_my_twat" add-addr download + ] with-temp-directory + ] must-fail -[ ] [ stop-test-httpd ] unit-test + [ ] [ stop-test-httpd ] unit-test + +] test-with-dispatcher ! Check that index.fhtml works -[ ] [ - - "resource:basis/http/test/" enable-fhtml >>default - add-quit-action - test-httpd -] unit-test + + "resource:basis/http/test/" enable-fhtml >>default + add-quit-action [ -[ "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 -[ ] [ - - add-quit-action - test-httpd -] unit-test + + 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 -- 2.34.1