Fix Yuuki's file responder bug
parent
87332eedad
commit
7f75944459
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue