From 7a8dc804267988acd4293d0f7bc83bafd2f4d66b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 Jan 2009 20:54:49 -0600 Subject: [PATCH] Fix some issues in http.server --- basis/http/http-tests.factor | 7 ++++--- .../server/dispatchers/dispatchers-tests.factor | 1 - basis/http/server/server-tests.factor | 2 ++ basis/http/server/server.factor | 17 +++++++++-------- basis/http/server/static/static-tests.factor | 4 ++++ basis/http/server/static/static.factor | 17 ++++++++++------- 6 files changed, 29 insertions(+), 19 deletions(-) create mode 100644 basis/http/server/static/static-tests.factor diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6103fb622f..c4ea23ea0a 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -298,7 +298,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test -USING: html.components html.elements html.forms +USING: html.components html.forms xml xml.utilities validators furnace furnace.conversations ; @@ -308,7 +308,7 @@ SYMBOL: a [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display + [ [ "a" render ] "text/html" ] >>display [ { { "a" [ v-integer ] } } validate-params ] >>validate [ "a" value a set-global URL" " ] >>submit @@ -322,7 +322,8 @@ SYMBOL: a 3 a set-global -: test-a string>xml "input" tag-named "value" attr ; +: test-a ( xml -- value ) + string>xml body>> "input" deep-tag-named "value" attr ; [ "3" ] [ "http://localhost/" add-port http-get diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 5b5b30adde..2c8db27259 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -4,7 +4,6 @@ assocs arrays classes words urls ; IN: http.server.dispatchers.tests \ find-responder must-infer -\ http-error. must-infer TUPLE: mock-responder path ; diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index c29912b8c7..fdba9a63ef 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ; IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test + +\ make-http-error must-infer diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 90a8ddb51a..97c14a6457 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -24,8 +24,9 @@ http.parsers http.server.responses http.server.remapping html.templates +html.streams html -html.streams ; +xml.writer ; IN: http.server : check-absolute ( url -- url ) @@ -173,15 +174,14 @@ main-responder global [ <404> or ] change-at : call-responder ( path responder -- response ) [ add-responder-nesting ] [ call-responder* ] 2bi ; -: http-error. ( error -- ) - ! TODO: get rid of rot - "Internal server error" [ ] rot '[ - [ _ print-error nl :c ] with-html-writer - ] simple-page ; +: make-http-error ( error -- xml ) + [ "Internal server error" f ] dip + [ print-error nl :c ] with-html-writer + simple-page ; : <500> ( error -- response ) 500 "Internal server error" - swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ; + swap development? get [ make-http-error >>body ] [ drop ] if ; : do-response ( response -- ) [ request get swap write-full-response ] @@ -190,7 +190,8 @@ main-responder global [ <404> or ] change-at [ utf8 [ development? get - [ http-error. ] [ drop "Response error" write ] if + [ make-http-error ] [ drop "Response error" ] if + write-xml ] with-encoded-output ] bi ] recover ; diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor new file mode 100644 index 0000000000..d54be03698 --- /dev/null +++ b/basis/http/server/static/static-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.static.tests +USING: http.server.static tools.test xml.writer ; + +[ ] [ "resource:basis" directory>html write-xml ] unit-test \ No newline at end of file diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 67ce0237a4..2df8838061 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -56,19 +56,22 @@ TUPLE: file-responder root hook special allow-listings ; \ serve-file NOTICE add-input-logging -: file. ( name -- xml ) +: file>html ( name -- xml ) dup link-info directory? [ "/" append ] when dup [XML
  • ><->
    • XML] ; -: directory. ( path -- ) - dup file-name [ ] [ - [ file-name ] [ directory-files [ file. ] map ] bi - [XML

    <->

      <->
    XML] write-xml - ] simple-page ; +: directory>html ( path -- xml ) + [ file-name ] + [ drop f ] + [ + [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi + [XML

    <->

      <->
    XML] + ] tri + simple-page ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - '[ _ directory. ] "text/html" + directory>html "text/html" ] [ drop <403> ] if ;