File responder directory listing fixes

darcs
slava 2006-02-01 03:43:29 +00:00
parent e364bbaddc
commit a40b1e12de
5 changed files with 23 additions and 40 deletions

View File

@ -10,22 +10,19 @@ global [
H{ } clone responders set
! 404 error message pages are served by this guy
[
"404" "responder" set
[ drop no-such-responder ] "get" set
] make-responder
"404" [ no-such-responder ] install-cont-responder
! Online help browsing
"help" [ help-responder ] install-cont-responder
! Javascript source used by ajax libraries
[
"contrib/httpd/javascript/" resource-path "doc-root" set
"javascript" "responder" set
[ file-responder ] "get" set
[ file-responder ] "post" set
[ file-responder ] "head" set
] make-responder
"javascript" [
[
"contrib/httpd/javascript/" resource-path
"doc-root" set
file-responder
] with-scope
] install-cont-responder
! Global variables
"inspector" [ inspect-responder ] install-cont-responder
@ -36,13 +33,7 @@ global [
! Serves files from a directory stored in the "doc-root"
! variable. You can set the variable in the global namespace,
! or inside the responder.
[
! "/var/www/" "doc-root" set
"file" "responder" set
[ file-responder ] "get" set
[ file-responder ] "post" set
[ file-responder ] "head" set
] make-responder
"file" [ file-responder ] install-cont-responder
! The root directory is served by...
"file" set-default-responder

View File

@ -1,8 +1,8 @@
! Copyright (C) 2004,2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: file-responder
USING: html httpd kernel lists math namespaces parser sequences
io strings ;
USING: cont-responder html httpd io kernel lists math namespaces
parser sequences strings ;
: serving-path ( filename -- filename )
[ "" ] unless* "doc-root" get swap append ;
@ -49,13 +49,15 @@ io strings ;
: serve-object ( filename -- )
dup directory? [ serve-directory ] [ serve-file ] if ;
: file-responder ( filename -- )
"doc-root" get [
serving-path dup exists? [
serve-object
: file-responder ( -- )
[
"doc-root" get [
"argument" get serving-path dup exists? [
serve-object
] [
drop "404 not found" httpd-error
] if
] [
drop "404 not found" httpd-error
"404 doc-root not set" httpd-error
] if
] [
drop "404 doc-root not set" httpd-error
] if ;
] (show-final) ;

View File

@ -126,11 +126,8 @@ SYMBOL: responders
: set-default-responder ( name -- )
responder "default" responders get set-hash ;
: responder-argument ( argument -- argument )
dup empty? [ drop "default-argument" get ] when ;
: call-responder ( method argument responder -- )
[ responder-argument swap get call ] bind ;
over "argument" set [ swap get call ] bind ;
: serve-default-responder ( method url -- )
"default" responder call-responder ;

View File

@ -15,13 +15,6 @@ USE: lists
[ ] [ "404 not found" httpd-error ] unit-test
[ "arg" ] [
[
"arg" "default-argument" set
"" responder-argument
] with-scope
] unit-test
[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
[ ] [

View File

@ -32,7 +32,7 @@ DEFER: directory.
: (directory.) ( name path -- )
dup [ directory. ] curry
[ "/" append (file.) ] write-outliner ;
[ "/" append (file.) ] write-outliner terpri ;
: file. ( dir name -- )
tuck path+