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

Fix some issues in http.server

db4
Slava Pestov 2009-01-31 20:54:49 -06:00
parent 938d9c733e
commit 7a8dc80426
6 changed files with 29 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -298,7 +298,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ "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 xml xml.utilities validators
furnace furnace.conversations ; furnace furnace.conversations ;
@ -308,7 +308,7 @@ SYMBOL: a
<dispatcher> <dispatcher>
<action> <action>
[ a get-global "a" set-value ] >>init [ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display [ [ "a" <field> render ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate [ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit [ "a" value a set-global URL" " <redirect> ] >>submit
<conversations> <conversations>
@ -322,7 +322,8 @@ SYMBOL: a
3 a set-global 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" ] [ [ "3" ] [
"http://localhost/" add-port http-get "http://localhost/" add-port http-get

1
basis/http/server/dispatchers/dispatchers-tests.factor
View File

@ -4,7 +4,6 @@ assocs arrays classes words urls ;
IN: http.server.dispatchers.tests IN: http.server.dispatchers.tests
\ find-responder must-infer \ find-responder must-infer
\ http-error. must-infer
TUPLE: mock-responder path ; TUPLE: mock-responder path ;

2
basis/http/server/server-tests.factor
View File

@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer

17
basis/http/server/server.factor
View File

@ -24,8 +24,9 @@ http.parsers
http.server.responses http.server.responses
http.server.remapping http.server.remapping
html.templates html.templates
html.streams
html html
html.streams ; xml.writer ;
IN: http.server IN: http.server
: check-absolute ( url -- url ) : check-absolute ( url -- url )
@ -173,15 +174,14 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: call-responder ( path responder -- response ) : call-responder ( path responder -- response )
[ add-responder-nesting ] [ call-responder* ] 2bi ; [ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- ) : make-http-error ( error -- xml )
! TODO: get rid of rot [ "Internal server error" f ] dip
"Internal server error" [ ] rot '[ [ print-error nl :c ] with-html-writer
[ _ print-error nl :c ] with-html-writer simple-page ;
] simple-page ;
: <500> ( error -- response ) : <500> ( error -- response )
500 "Internal server error" <trivial-response> 500 "Internal server error" <trivial-response>
swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ; swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- ) : do-response ( response -- )
[ request get swap write-full-response ] [ request get swap write-full-response ]
@ -190,7 +190,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[ [
utf8 [ utf8 [
development? get development? get
[ http-error. ] [ drop "Response error" write ] if [ make-http-error ] [ drop "Response error" ] if
write-xml
] with-encoded-output ] with-encoded-output
] bi ] bi
] recover ; ] recover ;

4
basis/http/server/static/static-tests.factor Normal file
View File

@ -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

17
basis/http/server/static/static.factor
View File

@ -56,19 +56,22 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging \ serve-file NOTICE add-input-logging
: file. ( name -- xml ) : file>html ( name -- xml )
dup link-info directory? [ "/" append ] when dup link-info directory? [ "/" append ] when
dup [XML <li><a href=<->><-></a></li> XML] ; dup [XML <li><a href=<->><-></a></li> XML] ;
: directory. ( path -- ) : directory>html ( path -- xml )
dup file-name [ ] [ [ file-name ]
[ file-name ] [ directory-files [ file. ] map ] bi [ drop f ]
[XML <h1><-></h1> <ul><-></ul> XML] write-xml [
] simple-page ; [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
[XML <h1><-></h1> <ul><-></ul> XML]
] tri
simple-page ;
: list-directory ( directory -- response ) : list-directory ( directory -- response )
file-responder get allow-listings>> [ file-responder get allow-listings>> [
'[ _ directory. ] "text/html" <content> directory>html "text/html" <content>
] [ ] [
drop <403> drop <403>
] if ; ] if ;