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

Fix Yuuki's file responder bug

darcs
slava 2006-12-20 02:12:50 +00:00
parent 87332eedad
commit 7f75944459
2 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
libs/httpd/file-responder.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: file-responder
USING: calendar embedded errors html httpd io kernel math USING: calendar embedded errors html httpd io kernel math
namespaces parser sequences strings hashtables ; namespaces parser sequences strings hashtables ;
IN: file-responder
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
[ "" ] unless* "doc-root" get swap path+ ; [ "" ] unless* "doc-root" get swap path+ ;
@ -53,12 +53,22 @@ SYMBOL: page
dup mime-type dup "application/x-factor-server-page" = dup mime-type dup "application/x-factor-server-page" =
[ drop serving-html run-page ] [ serve-static ] if ; [ drop serving-html run-page ] [ serve-static ] if ;
: file. ( path name -- )
tuck path+
directory? "[DIR] " " " ? write
write-pathname terpri ;
: directory. ( path -- )
dup directory natural-sort [ file. ] each-with ;
: list-directory ( directory -- ) : list-directory ( directory -- )
serving-html serving-html
"method" get "head" = [ "method" get "head" = [
drop drop
] [ ] [
"request" get [ dup log-message directory. ] simple-html-document "request" get [
"" swap directory.
] simple-html-document
] if ; ] if ;
: find-index ( filename -- path ) : find-index ( filename -- path )

13
libs/httpd/html.factor
View File

@ -62,7 +62,7 @@ IN: html
: padding-css, ( padding -- ) "padding: " % # "px; " % ; : padding-css, ( padding -- ) "padding: " % # "px; " % ;
: pre-css, ( -- ) : pre-css, ( -- )
"white-space: pre; font-family:monospace; " % ; "white-space: pre; font-family: monospace; " % ;
: div-css-style ( style -- str ) : div-css-style ( style -- str )
[ [
@ -88,16 +88,7 @@ GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ; M: object browser-link-href drop f ;
: resolve-file-link ( path -- link ) M: pathname browser-link-href pathname-string url-encode ;
#! The file responder needs relative links not absolute
#! links.
"doc-root" get [
?head [ "/" ?head drop ] when
] when* "/" ?tail drop ;
M: pathname browser-link-href
pathname-string
"/" swap resolve-file-link url-encode append ;
: object-link-tag ( style quot -- ) : object-link-tag ( style quot -- )
presented pick hash browser-link-href presented pick hash browser-link-href