]> gitweb.factorcode.org Git - factor.git/commitdiff
projects / factor.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 938d9c7)
Fix some issues in http.server
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Sun, 1 Feb 2009 02:54:49 +0000 (20:54 -0600)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Sun, 1 Feb 2009 02:54:49 +0000 (20:54 -0600)
basis/http/http-tests.factor patch | blob | history
basis/http/server/dispatchers/dispatchers-tests.factor patch | blob | history
basis/http/server/server-tests.factor patch | blob | history
basis/http/server/server.factor patch | blob | history
basis/http/server/static/static-tests.factor [new file with mode: 0644] patch | blob
basis/http/server/static/static.factor patch | blob | history

diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor
index 6103fb622f82b2d784cf547da0053bcbfe9a8787..c4ea23ea0aed9cfc5a77cc625f241b27a2a57929 100644 (file)
--- 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
     <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
diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor
index 5b5b30adde30e158da84d6ed805e2d9d0f0cd536..2c8db272596b3d933515c6141a80fbff5354437a 100644 (file)
--- 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 c29912b8c70a5f7949114b87308bb34e15167b09..fdba9a63efe89cab5a69e08795fa12bbf0bf6adb 100644 (file)
--- 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 90a8ddb51af0f965b79b619b9d5bfe2133eeb49e..97c14a6457df20a980150300da384fb3cadfe62c 100755 (executable)
--- 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> <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 ;
diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor
new file mode 100644 (file)
index 0000000..d54be03
--- /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 67ce0237a4d4dc5a6641721ca96a6a9af6d8bd01..2df883806167d7040ebeaf74c07db3dd8e9a0d39 100644 (file)
--- 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 ;
 \r
 \ serve-file NOTICE add-input-logging\r
 \r
-: file. ( name -- xml )\r
+: file>html ( name -- xml )\r
     dup link-info directory? [ "/" append ] when\r
     dup [XML <li><a href=<->><-></a></li> XML] ;\r
 \r
-: directory. ( path -- )\r
-    dup file-name [ ] [\r
-        [ file-name ] [ directory-files [ file. ] map ] bi\r
-        [XML <h1><-></h1> <ul><-></ul> XML] write-xml\r
-    ] simple-page ;\r
+: directory>html ( path -- xml )\r
+    [ file-name ]\r
+    [ drop f ]\r
+    [\r
+        [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi\r
+        [XML <h1><-></h1> <ul><-></ul> XML]\r
+    ] tri\r
+    simple-page ;\r
 \r
 : list-directory ( directory -- response )\r
     file-responder get allow-listings>> [\r
-        '[ _ directory. ] "text/html" <content>\r
+        directory>html "text/html" <content>\r
     ] [\r
         drop <403>\r
     ] if ;\r
Factor programming language