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
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
<dispatcher>
<action>
[ 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" value a set-global URL" " <redirect> ] >>submit
<conversations>
@ -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

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

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

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
[ 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.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> <trivial-responder> 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" <trivial-response>
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> <trivial-responder> 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 ;

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
: file. ( name -- xml )
: file>html ( name -- xml )
dup link-info directory? [ "/" append ] when
dup [XML <li><a href=<->><-></a></li> XML] ;
: directory. ( path -- )
dup file-name [ ] [
[ file-name ] [ directory-files [ file. ] map ] bi
[XML <h1><-></h1> <ul><-></ul> XML] write-xml
] simple-page ;
: directory>html ( path -- xml )
[ file-name ]
[ drop f ]
[
[ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
[XML <h1><-></h1> <ul><-></ul> XML]
] tri
simple-page ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
'[ _ directory. ] "text/html" <content>
directory>html "text/html" <content>
] [
drop <403>
] if ;