diff --git a/libs/httpd/file-responder.factor b/libs/httpd/file-responder.factor index 0f03a0689f..0e44afb266 100644 --- a/libs/httpd/file-responder.factor +++ b/libs/httpd/file-responder.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: file-responder USING: calendar embedded errors html httpd io kernel math namespaces parser sequences strings hashtables ; +IN: file-responder : serving-path ( filename -- filename ) [ "" ] unless* "doc-root" get swap path+ ; @@ -53,12 +53,22 @@ SYMBOL: page dup mime-type dup "application/x-factor-server-page" = [ 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 -- ) serving-html "method" get "head" = [ drop ] [ - "request" get [ dup log-message directory. ] simple-html-document + "request" get [ + "" swap directory. + ] simple-html-document ] if ; : find-index ( filename -- path ) diff --git a/libs/httpd/html.factor b/libs/httpd/html.factor index 5c7ca29f4e..fcdd231ec1 100644 --- a/libs/httpd/html.factor +++ b/libs/httpd/html.factor @@ -62,7 +62,7 @@ IN: html : padding-css, ( padding -- ) "padding: " % # "px; " % ; : pre-css, ( -- ) - "white-space: pre; font-family:monospace; " % ; + "white-space: pre; font-family: monospace; " % ; : div-css-style ( style -- str ) [ @@ -88,16 +88,7 @@ GENERIC: browser-link-href ( presented -- href ) M: object browser-link-href drop f ; -: resolve-file-link ( path -- link ) - #! 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 ; +M: pathname browser-link-href pathname-string url-encode ; : object-link-tag ( style quot -- ) presented pick hash browser-link-href