file responder: redirect if directory url does not end with /, and other changes to httpd

Makefile

@@ -1,5 +1,5 @@
-CC = gcc
-CFLAGS = -g -Os -mpentiumpro -Wall
+CC = gcc34
+CFLAGS = -Os -ffast-math -march=pentium4 -Wall -fomit-frame-pointer
 LIBS = -lm
 STRIP = strip
 
@@ -18,7 +18,7 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
 
 f: $(OBJS)
 	$(CC) $(LIBS) -o $@ $(OBJS)
-#	$(STRIP) $@
+	$(STRIP) $@
 
 clean:
 	rm -f $(OBJS)

TODO.FACTOR.txt

@@ -3,8 +3,6 @@
 - 'default responder' for when we go to root
 - file responder:
   - directory listings
-  - index.html
-  - if a directory is requested and URL does not end with /, redirect
 - minimize stage2 initialization code, just move it to source files
 
 + bignums:
@@ -85,6 +83,7 @@
 
 + misc:
 
+- don't rehash strings on every startup
 - 'cascading' styles
 - jedit ==> jedit-word, jedit takes a file name
 - rethink strhead/strtail&co

library/cross-compiler.factor

@@ -60,6 +60,7 @@ DEFER: sbuf-clone
 IN: io-internals
 DEFER: port?
 DEFER: open-file
+DEFER: stat
 DEFER: client-socket
 DEFER: server-socket
 DEFER: close-port
@@ -218,6 +219,7 @@ IN: cross-compiler
         getenv
         setenv
         open-file
+        stat
         garbage-collection
         save-image
         datastack

library/httpd/default-responders.factor

@@ -26,7 +26,10 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: httpd-responder
+USE: httpd
 USE: namespaces
+USE: stack
+USE: strings
 
 USE: test-responder
 USE: inspect-responder
@@ -34,10 +37,18 @@ USE: quit-responder
 USE: file-responder
 USE: wiki-responder
 
+: no-such-responder ( -- )
+    "404 No such responder" httpd-error ;
+
 : default-responders ( -- )
     #! Remove all existing responders, and create a blank
     #! responder table.
     <namespace> [
+        <responder> [
+            "404" "responder" set
+            [ drop no-such-responder ] "get" set
+        ] extend "404" set
+
         <responder> [
             "test" "responder" set
             [ test-responder ] "get" set
@@ -53,12 +64,12 @@ USE: wiki-responder
             "quit" "responder" set
             [ quit-responder ] "get" set
         ] extend "quit" set
- 
-         <responder> [
-             "file" "responder" set
-             [ file-responder ] "get" set
-         ] extend "file" set
- 
+
+        <responder> [
+            "file" "responder" set
+            [ file-responder ] "get" set
+        ] extend "file" set
+
 !        <responder> [
 !            "wiki" "responder" set
 !            [ wiki-get-responder ] "get" set

library/httpd/file-responder.factor

@@ -28,10 +28,11 @@
 IN: file-responder
 USE: combinators
 USE: errors
-USE: kernel
 USE: files
 USE: httpd
 USE: httpd-responder
+USE: kernel
+USE: logging
 USE: namespaces
 USE: parser
 USE: stack
@@ -39,12 +40,8 @@ USE: stdio
 USE: streams
 USE: strings
 
-: parse-object-name ( filename -- argument filename )
-    dup [ "?" split1 swap ] [ "/" ] ifte
-    "doc-root" get swap cat2 ;
-
-: serve-script ( argument filename -- )
-    [ swap "argument" set run-file ] with-scope ;
+: serving-path ( filename -- filename )
+    f>"" "doc-root" get swap cat2 ;
 
 : file-header ( mime-type -- header )
     "200 Document follows" swap response ;
@@ -52,22 +49,43 @@ USE: strings
 : copy-and-close ( from -- )
     [ dupd "stdio" get fcopy ] [ >r fclose r> rethrow ] catch ;
 
-: serve-static ( argument filename mime-type -- )
-    file-header print <filebr> "stdio" get fcopy drop ;
+: serve-static ( filename mime-type -- )
+    file-header print <filebr> "stdio" get fcopy ;
 
-: serve-file ( argument filename -- )
+: serve-file ( filename -- )
     dup mime-type dup "application/x-factor-server-page" = [
-        drop serve-script
+        drop run-file
     ] [
         serve-static
     ] ifte ;
 
-: file-responder ( filename -- )
-    "doc-root" get [
-        parse-object-name dup exists? [
+: directory-no/ ( -- )
+    <% "request" get % CHAR: / %
+    "raw-query" get [ CHAR: ? % % ] when*
+    %> redirect ;
+
+: serve-directory ( filename -- )
+    dup "/" str-tail? dup [
+        drop dup "index.html" cat2 dup exists? [
             serve-file
         ] [
-            2drop "404 not found" httpd-error
+            drop
+            "Foo bar" log
+            drop
+        ] ifte
+    ] [
+        2drop directory-no/
+    ] ifte ;
+
+: serve-object ( filename -- )
+    dup directory? [ serve-directory ] [ serve-file ] ifte ;
+
+: file-responder ( filename -- )
+    "doc-root" get [
+        serving-path dup exists? [
+            serve-object
+        ] [
+            drop "404 not found" httpd-error
         ] ifte
     ] [
         drop "404 doc-root not set" httpd-error

library/httpd/http-common.factor

@@ -55,6 +55,18 @@ USE: url-encoding
     dup log-error
     <% dup "text/html" response % error-body % %> print ;
 
+: serving-html ( -- )
+    "200 Document follows" "text/html" response print ;
+
+: serving-text ( -- )
+    "200 Document follows" "text/plain" response print ;
+
+: redirect ( to -- )
+    "301 Moved Permanently" "text/plain" response write
+    "Location: " write write
+    terpri terpri
+    "The resource has moved." print ;
+
 : header-line ( alist line -- alist )
     ": " split1 dup [ transp acons ] [ 2drop ] ifte ;
 
@@ -68,28 +80,34 @@ USE: url-encoding
 : content-length ( alist -- length )
     "Content-Length" swap assoc dec> ;
 
-: post-request>alist ( post-request -- alist )
-    "&" split [ "=" split1 cons ] map ;
-
-: url-decode-alist ( alist -- alist )
-    [ uncons >r url-decode r> url-decode cons ] map ;
+: query>alist ( query -- alist )
+    dup [
+        "&" split [
+            "=" split1
+            dup [ url-decode ] when swap
+            dup [ url-decode ] when swap cons
+        ] map
+    ] when ;
 
 : read-post-request ( header -- alist )
-    content-length dup [
-        read# post-request>alist url-decode-alist
-    ] when ;
+    content-length dup [ read# query>alist ] when ;
 
 : log-user-agent ( alist -- )
     "User-Agent" swap assoc* [
         unswons <% % ": " % % %> log
     ] when* ;
 
-: with-request ( method quot -- )
-    [
-        read-header "header" set
-        "header" get log-user-agent
-        swap "post" = [
-            "header" get read-post-request "response" set
-        ] when
-        call
-    ] with-scope ;
+: prepare-url ( url -- url )
+    #! This is executed in the with-request namespace.
+    "?" split1
+    dup "raw-query" set query>alist "query" set
+    dup "request" set ;
+
+: prepare-header ( -- )
+    read-header dup "header" set
+    dup log-user-agent
+    read-post-request "response" set ;
+
+: with-request ( url quot -- )
+    #! The quotation is called with the URL on the stack.
+    [ swap prepare-url swap prepare-header call ] with-scope ;

library/httpd/httpd.factor

@@ -61,11 +61,17 @@ USE: url-encoding
 : secure-path ( path -- path )
     ".." over str-contains? [ drop f ] when ;
 
+: get-request ( url -- )
+    [ "get" swap serve-responder ] with-request ;
+
+: post-request ( url -- )
+    [ "post" swap serve-responder ] with-request ;
+
 : handle-request ( arg cmd -- )
     [
-        [ "GET"  = ] [ drop "get"  serve-responder ]
-        [ "POST" = ] [ drop "post" serve-responder ]
-        [ drop t   ] [ 2drop bad-request           ]
+        [ "GET"  = ] [ drop get-request ]
+        [ "POST" = ] [ drop post-request ]
+        [ drop t   ] [ 2drop bad-request ]
     ] cond ;
 
 : parse-request ( request -- )

library/httpd/responder.factor

@@ -28,6 +28,7 @@
 IN: httpd-responder
 
 USE: combinators
+USE: httpd
 USE: kernel
 USE: lists
 USE: logging
@@ -37,7 +38,17 @@ USE: stack
 USE: streams
 USE: strings
 
-USE: httpd
+! Responders are called in a new namespace with these
+! variables:
+
+! - request -- the entire URL requested, including responder
+!              name
+! - raw-query -- raw query string
+! - query -- an alist of query parameters, eg
+!            foo.bar?a=b&c=d becomes
+!            [ [ "a" | "b" ] [ "c" | "d" ] ]
+! - header -- an alist of headers from the user's client
+! - response -- an alist of the POST request response
 
 : <responder> ( -- responder )
     <namespace> [
@@ -45,56 +56,34 @@ USE: httpd
         [
             drop "GET method not implemented" httpd-error
         ] "get" set
-
         ( url -- )
         [
             drop "POST method not implemented" httpd-error
         ] "post" set
     ] extend ;
 
-: serving-html ( -- )
-    "200 Document follows" "text/html" response print ;
-
-: serving-text ( -- )
-    "200 Document follows" "text/plain" response print ;
-
-: redirect ( to -- )
-    "301 Moved Permanently" "text/plain" response write
-    "Location: " write write
-    terpri terpri
-    "The resource has moved." print ;
-
 : get-responder ( name -- responder )
-    "httpd-responders" get get* ;
+    "httpd-responders" get get* [
+        "404" "httpd-responders" get get*
+    ] unless* ;
 
 : responder-argument ( argument -- argument )
     dup f-or-"" [ drop "default-argument" get ] when ;
 
 : call-responder ( method argument responder -- )
-    pick [
-        [ responder-argument swap get call ] bind
-    ] with-request ;
-
-: no-such-responder ( name -- )
-    "404 no such responder: " swap cat2 httpd-error ;
+    [ responder-argument swap get call ] bind ;
 
 : trim-/ ( url -- url )
     #! Trim a leading /, if there is one.
     dup "/" str-head? dup [ nip ] [ drop ] ifte ;
 
-: log-responder ( argument -- )
+: log-responder ( url -- )
     "Calling responder " swap cat2 log ;
 
-: serve-responder ( argument method -- )
-    swap
-    dup log-responder
-    trim-/ "/" split1 dup [
-        over get-responder dup [
-            rot drop call-responder
-        ] [
-            2drop no-such-responder drop
-        ] ifte
+: serve-responder ( method url -- )
+    dup log-responder trim-/ "/" split1 dup [
+        swap get-responder call-responder
     ] [
-        ! Argument is just a responder name without /
+        ! Just a responder name by itself
         drop "/" swap "/" cat3 redirect drop
     ] ifte ;

library/init.factor

@@ -30,6 +30,7 @@ USE: combinators
 USE: compiler
 USE: continuations
 USE: errors
+USE: files
 USE: interpreter
 USE: kernel
 USE: lists

library/platform/jvm/boot-mini.factor

@@ -67,6 +67,7 @@ USE: parser
 "/library/platform/jvm/regexp.factor"       run-resource ! regexp
 "/library/stream.factor"                    run-resource ! streams
 "/library/platform/jvm/stream.factor"       run-resource ! streams
+"/library/platform/jvm/files.factor"        run-resource ! files
 "/library/stdio.factor"                     run-resource ! stdio
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser

library/platform/jvm/boot-sumo.factor

@@ -67,13 +67,14 @@ USE: parser
 "/library/platform/jvm/regexp.factor"       run-resource ! regexp
 "/library/stream.factor"                    run-resource ! streams
 "/library/platform/jvm/stream.factor"       run-resource ! streams
+"/library/platform/jvm/files.factor"        run-resource ! files
+"/library/files.factor"                     run-resource ! files
 "/library/stdio.factor"                     run-resource ! stdio
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser
 "/library/styles.factor"                    run-resource ! styles
 "/library/platform/jvm/threads.factor"      run-resource ! threads
 "/library/logging.factor"                   run-resource ! logging
-"/library/files.factor"                     run-resource ! files
 
 !!! Math library.
 "/library/platform/jvm/real-math.factor" run-resource ! real-math

library/platform/jvm/files.factor

@@ -0,0 +1,59 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: files
+USE: combinators
+USE: kernel
+USE: lists
+USE: logic
+USE: stack
+USE: strings
+
+: <file> ( path -- file )
+    dup "java.io.File" is not [
+        [ "java.lang.String" ] "java.io.File" jnew
+    ] when ;
+
+: delete ( file -- ? )
+    #! Delete a file.
+    <file> [ ] "java.io.File" "delete" jinvoke ;
+
+: exists? ( file -- boolean )
+    <file> [ ] "java.io.File" "exists" jinvoke ;
+
+: directory? ( file -- boolean )
+    <file> [ ] "java.io.File" "isDirectory" jinvoke ;
+
+: directory ( file -- listing )
+    <file> [ ] "java.io.File" "list" jinvoke array>list str-sort ;
+
+: rename ( from to -- ? )
+    ! Rename file 'from' to 'to'. These can be paths or
+    ! java.io.File instances.
+    <file> swap <file>
+    [ "java.io.File" ] "java.io.File" "renameTo"
+    jinvoke ;

library/platform/jvm/stream.factor

@@ -32,7 +32,6 @@ USE: kernel
 USE: lists
 USE: logic
 USE: namespaces
-USE: regexp
 USE: stack
 USE: strings
 
@@ -185,34 +184,9 @@ USE: strings
     f swap
     <byte-stream> ;
 
-: <file> ( path -- file )
-    dup "java.io.File" is not [
-        [ "java.lang.String" ] "java.io.File" jnew
-    ] when ;
-
-: fdelete ( file -- ? )
-    #! Delete a file.
-    <file> [ ] "java.io.File" "delete" jinvoke ;
-
 : <freader> ( file -- freader )
     [ "java.lang.String" ] "java.io.FileReader" jnew <breader> ;
 
-: exists? ( file -- boolean )
-    <file> [ ] "java.io.File" "exists" jinvoke ;
-
-: directory? ( file -- boolean )
-    <file> [ ] "java.io.File" "isDirectory" jinvoke ;
-
-: directory ( file -- listing )
-    <file> [ ] "java.io.File" "list" jinvoke array>list str-sort ;
-
-: frename ( from to -- ? )
-    ! Rename file 'from' to 'to'. These can be paths or
-    ! java.io.File instances.
-    <file> swap <file>
-    [ "java.io.File" ] "java.io.File" "renameTo"
-    jinvoke ;
-
 : <sreader> ( string -- reader )
     [ "java.lang.String" ] "java.io.StringReader" jnew ;
 

library/platform/native/boot-stage2.factor

@@ -98,6 +98,7 @@ USE: stdio
     "/library/random.factor"
     "/library/stdio-binary.factor"
     "/library/platform/native/prettyprint.factor"
+    "/library/platform/native/files.factor"
     "/library/files.factor"
     "/library/interpreter.factor"
     "/library/inspector.factor"

library/platform/native/files.factor

@@ -0,0 +1,44 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: files
+USE: combinators
+USE: io-internals
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: stack
+
+: exists? ( file -- ? )
+    stat >boolean ;
+
+: dir-mode
+    OCT: 40000 ;
+
+: directory? ( file -- ? )
+    stat dup [ car dir-mode bitand 0 = not ] when ;

library/platform/native/stream.factor

@@ -80,10 +80,6 @@ USE: namespaces
 : init-stdio ( -- )
     stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
 
-: exists? ( file -- ? )
-    #! This is terrible.
-    [ <filebr> fclose t ] [ nip not ] catch ;
-
 : fcopy ( from to -- )
     #! Copy the contents of the fd-stream 'from' to the
     #! fd-stream 'to'.

library/strings.factor

@@ -36,6 +36,9 @@ USE: stack
 : f-or-"" ( obj -- ? )
     dup not swap "" = or ;
 
+: f>"" ( str/f -- str )
+    [ "" ] unless* ;
+
 : str-length< ( str str -- boolean )
     #! Compare string lengths.
     [ str-length ] 2apply < ;

library/test/httpd/httpd.factor

@@ -14,7 +14,6 @@ USE: url-encoding
 [ 5430 ]
 [ f "Content-Length: 5430" header-line content-length ] unit-test
 
-
 [ "hello world"   ] [ "hello+world"    url-decode ] unit-test
 [ "hello world"   ] [ "hello%20world"  url-decode ] unit-test
 [ " ! "           ] [ "%20%21%20"      url-decode ] unit-test
@@ -23,8 +22,6 @@ USE: url-encoding
 [ "hello%20world" ] [ "hello world"    url-encode ] unit-test
 [ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
 
-! These make sure the words work, and don't leave
-! extra crap on the stakc
 [ ] [ "404 not found" ] [ httpd-error ] test-word
 
 [ "arg" ] [
@@ -60,13 +57,18 @@ USE: url-encoding
 [ f ]
 [ "foobar/../baz" secure-path ] unit-test
 
-[ ] [ "GET /index.html" parse-request ] unit-test
 [ ] [ "GET ../index.html" parse-request ] unit-test
 [ ] [ "POO" parse-request ] unit-test
 
-[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" post-request>alist ] unit-test
+[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" query>alist ] unit-test
+
 [ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ]
-[ "Foo=Bar&Baz=Quux" post-request>alist ] unit-test
+[ "Foo=Bar&Baz=Quux" query>alist ] unit-test
+
+[ [ [ "Baz" | " " ] ] ]
+[ "Baz=%20" query>alist ] unit-test
+
+[ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test
 
 [ f "/foo/hello.html" ] [
     [

native/factor.h

@@ -15,6 +15,7 @@
 #include <sys/param.h>
 #include <sys/types.h>
 #include <sys/socket.h>
+#include <sys/stat.h>
 #include <netinet/in.h>
 #include <arpa/inet.h>
 #include <unistd.h>

native/file.c

@@ -24,3 +24,23 @@ void primitive_open_file(void)
 	dpush(read ? tag_object(port(PORT_READ,fd)) : F);
 	dpush(write ? tag_object(port(PORT_WRITE,fd)) : F);
 }
+
+void primitive_stat(void)
+{
+	struct stat sb;
+	STRING* path = untag_string(dpop());
+	if(stat(to_c_string(path),&sb) < 0)
+		dpush(F);
+	else
+	{
+		CELL mode = tag_integer(sb.st_mode);
+		CELL size = tag_object(s48_long_long_to_bignum(sb.st_size));
+		CELL mtime = tag_integer(sb.st_mtime);
+		dpush(tag_cons(cons(
+			mode,
+			tag_cons(cons(
+				size,
+				tag_cons(cons(
+					mtime,F)))))));
+	}
+}

native/file.h

@@ -1,3 +1,4 @@
 #define FILE_MODE 0600
 
 void primitive_open_file(void);
+void primitive_stat(void);

native/primitives.c

@@ -108,6 +108,7 @@ XT primitives[] = {
 	primitive_getenv,
 	primitive_setenv,
 	primitive_open_file,
+	primitive_stat,
 	primitive_gc,
 	primitive_save_image,
 	primitive_datastack,

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 145
+#define PRIMITIVE_COUNT 146
 
 CELL primitive_to_xt(CELL primitive);

native/relocate.c

@@ -21,6 +21,9 @@ void relocate_object()
 	case VECTOR_TYPE:
 		fixup_vector((VECTOR*)relocating);
 		break;
+	case STRING_TYPE:
+		hash_string((STRING*)relocating);
+		break;
 	case SBUF_TYPE:
 		fixup_sbuf((SBUF*)relocating);
 		break;