Rework once again how content types, content encodings, icons etc. are

handled in the file/directory request handlers:

- HTTPD-FILE-DIRECTORY-HANDLERS now has its own options argument
- the ICON-NAME HTTPD option is gone (effectively moved to the above)
- determination of content type/encoding is now configurable
This commit is contained in:
sperber 2003-01-28 15:16:20 +00:00
parent eb20aec688
commit 022ea25ba6
6 changed files with 283 additions and 176 deletions

View File

@ -75,41 +75,6 @@ one. Here they are:
server uses in automatically generated replies. Defaults to \ex{\#f}.
\end{desc}
\defun{with-icon-name}{icon-name [options]}{options}
\begin{desc}
This specifies how to generate the links to various decorative icons
for the listings. It can either be a procedure which gets passed an
icon tag (a symbol) and is expected to return a link pointing to the icon. If
it is a string, that is taken as prefix to which the icon tag are
appended. If \ex{\#f}, just the plain file names will be used. Defaults to \ex{\#f}.
The valid icon tags, together with the default names of their icon
files, are:
\begin{center}
\begin{tabular}{|l|l|}
\hline
\texttt{directory} & \texttt{directory.xbm}\\\hline
\texttt{text} & \texttt{text.xbm}\\\hline
\texttt{doc} & \texttt{doc.xbm}\\\hline
\texttt{image} & \texttt{image.xbm}\\\hline
\texttt{movie} & \texttt{movie.xbm}\\\hline
\texttt{audio} & \texttt{sound.xbm}\\\hline
\texttt{archive} & \texttt{tar.xbm}\\\hline
\texttt{compressed} & \texttt{compressed.xbm}\\\hline
\texttt{uu} & \texttt{uu.xbm}\\\hline
\texttt{binhex} & \texttt{binhex.xbm}\\\hline
\texttt{binary} & \texttt{binary.xbm}\\\hline
\texttt{blank} & \texttt{blank.xbm}\\\hline
\texttt{back} & \texttt{back.xbm}\\\hline
unknown & \texttt{unknown.xbm}\\\hline
\end{tabular}
Example icons can be found as part of the CERN httpd distribution
at \url{http://www.w3.org/pub/WWW/Daemon/}.
\end{center}
\end{desc}
\defun{with-request-handler}{request-handler [options]}{options}
\begin{desc}
This specifies the request handler of the server to which the server
@ -493,24 +458,94 @@ simple directory-generation service using the following rules:
\item If the filename names a regular file, it is served to the
client.
\end{itemize}
%
The \ex{httpd-file-directory-handlers} all take an options value as an
argument, similar to the options for \ex{httpd} itself.
\defun{rooted-file-handler}{root-dir}{request-handler}
The \var{options} argument can be constructed through a number of procedures
with names of the form \texttt{with-\ldots}. Each of these procedures
either creates a fresh options value or adds a configuration parameter
to an old options argument. The configuration parameter value is
always the first argument, the (old) options value the optional second
one. Here they are:
\defun{with-file-name->content-type}{proc [options]}{options}
\begin{desc}
This specifies a procedure for determining the MIME content type
(``\ex{text/html},'' ``\ex{application/octet-stream}'' etc.)
from a file name. \var{Proc} takes a file name as an argument and
must return a string. (This is relevant in directory listings.) The default is a procedure able to handle the
more common file extensions.
\end{desc}
\defun{with-file-name->content-encoding}{proc [options]}{options}
\begin{desc}
This specifies a procedure for determining the MIME content encoding
(if the file is compressed, gzipped, etc.) from a file name.
(This is relevant in directory listings.)
\var{Proc} takes a file name as an argument and must return two
values: the equivalent, unencoded file name (i.e., without the
trailing \ex{.Z} or \ex{.gz}) and a string representing the content
encoding.
\end{desc}
\defun{with-file-name->icon-file-name}{proc [options]}{options}
\begin{desc}
This specifies a procedure for determining the icon to be displayed
next to a file name in a directory listing.
\var{Proc} takes a file name as an argument and must return a URI
representing the corresponding icon.
\end{desc}
\defun{with-blank-icon-file-name}{file-name [options]}{options}
\begin{desc}
This specifies a file name for the special icon that must be as wide
as the icons returned by the previous procedure but that is blank.
\end{desc}
\defun{with-back-icon-file-name}{file-name [options]}{options}
\begin{desc}
This specifies a file name for the special icon that is displayed
next to the ``parent directory'' link in directory listings.
\end{desc}
\defun{with-unknown-icon-file-name}{file-name [options]}{options}
\begin{desc}
This specifies a file name for the special icon that is displayed
next to the unknown entries in directory listings.
\end{desc}
The \ex{make-file-directory-options} procedure eases the construction
of the options argument:
\defun{make-file-directory-options}{transformer value \ldots}{options}
\begin{desc}
This constructs an options value from an argument list of parameter
transformers and parameter values. The arguments come in pairs,
each an option transformer from the list above, and a value for that
parameter. \ex{Make-file-directory-options} returns the resulting
options value.
\end{desc}
%
Here are procedure for constructing static content request handlers:
%
\defun{rooted-file-handler}{root options}{request-handler}
\begin{desc}
This returns a request handler that serves files from a particular
root in the file system. Only the \ex{GET} operation is provided.
The path argument passed to the handler is converted into a
filename, and appended to root-dir. The file name is checked for
filename, and appended to \var{root}. The file name is checked for
\ex{..} components, and the transaction is aborted if it does.
Otherwise, the file is served to the client.
\end{desc}
\defun{rooted-file-or-directory-handler}{root}{request-handler}
\defun{rooted-file-or-directory-handler}{root options}{request-handler}
\begin{desc}
Dito, but also serve directory indices for directories without
\ex{index.html}.
\end{desc}
\defun{home-dir-handler}{subdir}{request-handler}
\defun{home-dir-handler}{subdir options}{request-handler}
\begin{desc}
This procedure builds a request handler that does basic file serving
out of home directories. If the resulting \var{request-handler} is
@ -521,8 +556,7 @@ Dito, but also serve directory indices for directories without
allowed to contain \ex{..} elements.
\end{desc}
\defun{tilde-home-dir-handler}{subdir
default-request-handler}{request-handler}
\defun{tilde-home-dir-handler}{subdir default-request-handler options}{request-handler}
\begin{desc}
This returns request handler that examines the car of the path. If
it is a string beginning with a tilde, e.g., \ex{"~ziggy"}, then the

View File

@ -3,12 +3,107 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 1996-2003 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define server/buffer-size 8192) ; WTF
(define-record-type file-directory-options :file-directory-options
(really-make-file-directory-options file-name->content-type
file-name->content-encoding
file-name->icon-file-name
directory-icon-file-name
blank-icon-file-name
back-icon-file-name
unknown-icon-file-name)
file-directory-options?
(file-name->content-type file-directory-options-file-name->content-type
set-file-directory-options-file-name->content-type!)
(file-name->content-encoding file-directory-options-file-name->content-encoding
set-file-directory-options-file-name->content-encoding!)
(file-name->icon-file-name file-directory-options-file-name->icon-file-name
set-file-directory-options-file-name->icon-file-name!)
(directory-icon-file-name file-directory-options-directory-icon-file-name
set-file-directory-options-directory-icon-file-name!)
(blank-icon-file-name file-directory-options-blank-icon-file-name
set-file-directory-options-blank-icon-file-name!)
(back-icon-file-name file-directory-options-back-icon-file-name
set-file-directory-options-back-icon-file-name!)
(unknown-icon-file-name file-directory-options-unknown-icon-file-name
set-file-directory-options-unknown-icon-file-name!))
(define (make-default-file-directory-options)
(really-make-file-directory-options default-file-name->content-type
default-file-name->content-encoding
default-file-name->icon-file-name
"directory.xbm"
"blank.xbm"
"back.xbm"
"unknown.xbm"))
(define (copy-file-directory-options options)
(let ((new-options (make-default-file-directory-options)))
(set-file-directory-options-file-name->content-type!
new-options
(file-directory-options-file-name->content-type options))
(set-file-directory-options-file-name->content-encoding!
new-options
(file-directory-options-file-name->content-encoding options))
(set-file-directory-options-file-name->icon-file-name!
new-options
(file-directory-options-file-name->icon-file-name options))
(set-file-directory-options-directory-icon-file-name!
new-options
(file-directory-options-directory-icon-file-name options))
(set-file-directory-options-blank-icon-file-name!
new-options
(file-directory-options-blank-icon-file-name options))
(set-file-directory-options-back-icon-file-name!
new-options
(file-directory-options-back-icon-file-name options))
(set-file-directory-options-unknown-icon-file-name!
new-options
(file-directory-options-unknown-icon-file-name options))
new-options))
(define (make-file-directory-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-file-directory-options (car stuff))
(make-default-file-directory-options))))
(set-option! new-options new-value)
new-options)))
(define with-file-name->content-type
(make-file-directory-options-transformer
set-file-directory-options-file-name->content-type!))
(define with-file-name->content-encoding
(make-file-directory-options-transformer
set-file-directory-options-file-name->content-encoding!))
(define with-file-name->icon-file-name
(make-file-directory-options-transformer
set-file-directory-options-file-name->icon-file-name!))
(define with-blank-icon-file-name
(make-file-directory-options-transformer
set-file-directory-options-blank-icon-file-name!))
(define with-back-icon-file-name
(make-file-directory-options-transformer
set-file-directory-options-back-icon-file-name!))
(define with-unknown-icon-file-name
(make-file-directory-options-transformer
set-file-directory-options-unknown-icon-file-name!))
(define (make-file-directory-options . stuff)
(let loop ((options (make-default-file-directory-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))
;;; (home-dir-handler user-public-dir) -> handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return a request handler that looks things up in a specific directory
@ -22,7 +117,7 @@
;;; serving
;;; ~<user>/<user-public-dir>/<file-path>
(define (home-dir-handler user-public-dir)
(define (home-dir-handler user-public-dir options)
(lambda (path req)
(if (null? path)
(make-error-response (status-code bad-request)
@ -33,7 +128,8 @@
user-public-dir)
(cdr path)
file-serve-response
req))))
req
options))))
;;; (tilde-home-dir-handler user-public-dir default-request-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -47,7 +143,7 @@
(and (> (string-length head) 0)
(char=? (string-ref head 0) #\~)))))
(define (tilde-home-dir-handler user-public-dir default-handler)
(define (tilde-home-dir-handler user-public-dir default-handler options)
(make-predicate-handler
tilde-home-dir?
(lambda (path req)
@ -57,7 +153,8 @@
(http-homedir (substring tilde-home 1 slen) req)
"/"
user-public-dir)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req
options)))
default-handler))
@ -65,25 +162,26 @@
;;; in the file system. You may follow symlinks, but you can't back up
;;; past ROOT with ..'s.
(define (rooted-file-handler root)
(define (rooted-file-handler root options)
(lambda (path req)
(make-rooted-file-path-response root path file-serve-response req)))
(make-rooted-file-path-response root path file-serve-response req options)))
;;; Dito, but also serve directory indices for directories without
;;; index.html.
(define (rooted-file-or-directory-handler root)
(define (rooted-file-or-directory-handler root options)
(lambda (path req)
(make-rooted-file-path-response root path
file-serve-and-dir-response
req)))
req
options)))
;;;; Support procs for the path handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req)
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req options)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Do a request for a file. The file-name is determined by appending the
;;; the FILE-PATH list the string ROOT. E.g., if
@ -111,13 +209,13 @@
;;; security checks. Look in ROOTED-FILE-HANDLER and
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
(define (make-rooted-file-path-response root file-path file-serve-response req)
(define (make-rooted-file-path-response root file-path file-serve-response req options)
(if (http-url-search (request-url req))
(make-error-response (status-code bad-request) req
"Indexed search not provided for this URL.")
(cond ((dotdot-check root file-path) =>
(lambda (fname)
(file-serve-response fname file-path req)))
(file-serve-response fname file-path req options)))
(else
(make-error-response (status-code bad-request) req
"URL contains unresolvable ..'s.")))))
@ -138,9 +236,9 @@
;;; checking. That has presumably been taken care of. This handler only
;;; takes care of GET and HEAD methods.
(define (file-serve-or-dir-response fname file-path req directory-serve-response)
(define (file-serve-or-dir-response fname file-path req directory-serve-response options)
(if (file-name-directory? fname) ; Simple index generation.
(directory-serve-response fname file-path req)
(directory-serve-response fname file-path req options)
(let ((request-method (request-method req)))
(cond
@ -150,7 +248,7 @@
(case (file-info:type info)
((regular fifo socket)
(send-file-response fname info req))
(send-file-response fname info req options))
((directory) ; Send back a redirection "foo" -> "foo/"
(make-error-response
@ -165,52 +263,21 @@
(make-error-response (status-code method-not-allowed) req
request-method))))))
(define (directory-index-serve-response fname file-path req)
(file-serve-response (string-append fname "index.html") file-path req))
(define (directory-index-serve-response fname file-path req options)
(file-serve-response (string-append fname "index.html") file-path req options))
(define (file-serve-response fname file-path req)
(define (file-serve-response fname file-path req options)
(file-serve-or-dir-response fname file-path req
directory-index-serve-response))
(define (tag->alt tag)
(case tag
((directory) "[DIR]")
((text) "[TXT]")
((doc) "[DOC]")
((image) "[IMG]")
((movie) "[MVI]")
((audio) "[AU ]")
((archive) "[TAR]")
((compressed) "[ZIP]")
((uu) "[UU ]")
((binhex) "[HQX]")
((binary) "[BIN]")
(else "[ ]")))
directory-index-serve-response
options))
;; These icons can, for example, be found in the cern-httpd-3.0
;; distribution at http://www.w3.org/pub/WWW/Daemon/
(define (tag->icon tag)
(case tag
((directory) "directory.xbm")
((text) "text.xbm")
((doc) "doc.xbm")
((image) "image.xbm")
((movie) "movie.xbm")
((audio) "sound.xbm")
((archive) "tar.xbm")
((compressed) "compressed.xbm")
((uu) "uu.xbm")
((binhex) "binhex.xbm")
((binary) "binary.xbm")
((blank) "blank.xbm")
((back) "back.xbm")
(else "unknown.xbm")))
(define (file-extension->tag fname)
(define (default-file-name->icon-file-name fname)
(let ((ext (file-name-extension fname)))
(cond
((string-ci=? ext ".txt") 'text)
((string-ci=? ext ".txt") "text.xbm")
((or (string-ci=? ext ".doc")
(string-ci=? ext ".htm")
(string-ci=? ext ".html")
@ -218,35 +285,30 @@
(string-ci=? ext ".pdf")
(string-ci=? ext ".dvi")
(string-ci=? ext ".ps")
(string-ci=? ext ".tex")) 'doc)
(string-ci=? ext ".tex")) "doc.xbm")
((or (string-ci=? ext ".bmp")
(string-ci=? ext ".gif")
(string-ci=? ext ".png")
(string-ci=? ext ".jpg")
(string-ci=? ext ".jpeg")
(string-ci=? ext ".tiff")
(string-ci=? ext ".tif")) 'image)
(string-ci=? ext ".tif")) "image.xbm")
((or (string-ci=? ext ".mpeg")
(string-ci=? ext ".mpg")) 'movie)
(string-ci=? ext ".mpg")) "movie.xbm")
((or (string-ci=? ext ".au")
(string-ci=? ext ".snd")
(string-ci=? ext ".mp3")
(string-ci=? ext ".wav")) 'audio)
(string-ci=? ext ".wav")) "sound.xbm")
((or (string-ci=? ext ".tar")
(string-ci=? ext ".zip")
(string-ci=? ext ".zoo")) 'archive)
(string-ci=? ext ".zoo")) "tar.xbm")
((or (string-ci=? ext ".gz")
(string-ci=? ext ".bz2")
(string-ci=? ext ".Z")
(string-ci=? ext ".z")) 'compressed)
((string-ci=? ext ".uu") 'uu)
((string-ci=? ext ".hqx") 'binhex)
(else 'binary))))
(define (file-tag fname type)
(case type
((regular fifo socket) (file-extension->tag fname))
((directory) 'directory)
(else 'unknown)))
(string-ci=? ext ".z")) "compressed.xbm")
((string-ci=? ext ".uu") "uu.xbm")
((string-ci=? ext ".hqx") "binhex.xbm")
(else "binary.xbm"))))
(define (time->directory-index-date-string time)
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
@ -290,9 +352,9 @@
n)))))
(else ""))))))
(define (file-documentation fname n)
(define (file-documentation fname n options)
(cond
((file-extension->content-type fname)
(((file-directory-options-file-name->content-type options) fname)
=> (lambda (content-type)
(if (and (string=? content-type "text/html" )
(file-readable? fname))
@ -300,7 +362,7 @@
"")))
(else "")))
(define (directory-index req dir icon-name port)
(define (directory-index req dir port options)
(define (pad-file-name file)
(write-string (make-string (max (- 21 (string-length file))
@ -319,10 +381,23 @@
(info (file-info fname #t))
(type (file-info:type info))
(size (file-info:size info))
(tag (file-tag file type)))
(icon-name
(case type
((regular fifo socket)
((file-directory-options-file-name->icon-file-name options)
fname))
((directory)
(file-directory-options-directory-icon-file-name options))
(else
(file-directory-options-unknown-icon-file-name options))))
(tag-name
(case type
((regular fifo socket) "[FILE]")
((directory) "[DIR ]")
(else "[????]"))))
(emit-tag port 'img
(cons 'src (icon-name tag))
(cons 'alt (tag->alt tag)))
(cons 'src icon-name)
(cons 'alt tag-name))
(with-tag port a ((href file))
(emit-file-name file))
(pad-file-name file)
@ -345,14 +420,14 @@
(write-string size-string port))
(write-string (make-string 8 #\space) port))
(write-char #\space port)
(emit-text (file-documentation fname 24) port)
(emit-text (file-documentation fname 24 options) port)
(write-crlf port)))
(let ((files (directory-files dir)))
(for-each index-entry files)
(length files)))
(define (directory-serve-response fname file-path req)
(define (directory-serve-response fname file-path req options)
(let ((request-method (request-method req)))
(cond
((or (string=? request-method "GET")
@ -368,15 +443,11 @@
"text/html"
'()
(make-writer-body
(lambda (port options)
(let* ((icon-option (httpd-options-icon-name options))
(icon-name
(cond
((procedure? icon-option) icon-option)
((string? icon-option)
(lambda (tag)
(string-append icon-option (tag->icon tag))))
(else tag->icon))))
(lambda (port httpd-options)
(let ((back-icon
(file-directory-options-back-icon-file-name options))
(blank-icon
(file-directory-options-blank-icon-file-name options)))
(with-tag port html ()
(let ((title (string-append "Index of /"
(string-join file-path "/"))))
@ -386,7 +457,7 @@
(emit-header port 1 title)
(with-tag port pre ()
(emit-tag port 'img
(cons 'src (icon-name 'blank))
(cons 'src blank-icon)
(cons 'alt " "))
(write-string "Name " port)
(write-string "Last modified " port)
@ -394,29 +465,30 @@
(write-string "Description" port)
(emit-tag port 'hr)
(emit-tag port 'img
(cons 'src (icon-name 'back))
(cons 'src back-icon)
(cons 'alt "[UP ]"))
(if (not (null? file-path))
(begin
(with-tag port a ((href ".."))
(write-string "Parent directory" port))
(write-crlf port)))
(let ((n-files (directory-index req fname icon-name port)))
(let ((n-files (directory-index req fname port options)))
(emit-tag port 'hr)
(format port "~d files" n-files))))))))))))
(else
(make-error-response (status-code method-not-allowed) req
request-method)))))
(define (index-or-directory-serve-response fname file-path req)
(define (index-or-directory-serve-response fname file-path req options)
(let ((index-fname (string-append fname "index.html")))
(if (file-readable? index-fname)
(file-serve-response index-fname file-path req)
(directory-serve-response fname file-path req))))
(file-serve-response index-fname file-path req options)
(directory-serve-response fname file-path req options))))
(define (file-serve-and-dir-response fname file-path req)
(define (file-serve-and-dir-response fname file-path req options)
(file-serve-or-dir-response fname file-path req
index-or-directory-serve-response))
index-or-directory-serve-response
options))
;;; Look up user's home directory, generating an HTTP error response if you lose.
@ -425,19 +497,19 @@
(apply http-error (status-code bad-request) req
"Couldn't find user's home directory."
(condition-stuff c)))
(home-dir username)))
(define (send-file-response filename info req)
(define (send-file-response filename info req options)
(if (file-not-readable? filename) ; #### double stats are no good
(make-error-response (status-code not-found) req)
(receive (stripped-filename content-encoding)
(file-extension->content-encoding filename)
((file-directory-options-file-name->content-encoding options) filename)
(make-response (status-code ok)
#f
(time)
(file-extension->content-type stripped-filename)
((file-directory-options-file-name->content-type options)
stripped-filename)
(append (if content-encoding
(cons 'content-encoding content-encoding)
'())
@ -453,7 +525,7 @@
(copy-inport->outport in port)))))))))
(define (file-extension->content-type fname)
(define (default-file-name->content-type fname)
(let ((ext (file-name-extension fname)))
(cond
((string-ci=? ext ".htm") "text/html")
@ -483,7 +555,7 @@
((string-ci=? ext ".pdf") "application/pdf")
(else "application/octet-stream"))))
(define (file-extension->content-encoding fname)
(define (default-file-name->content-encoding fname)
(cond
((let ((ext (file-name-extension fname)))
(cond

View File

@ -15,10 +15,11 @@
(define rh1
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options)))
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
(rooted-file-handler "/usr/local/etc/httpd/htdocs"
(make-file-directory-options))))
;;; Do a rough approximation of NCSA httpd server semantics:
@ -31,7 +32,9 @@
(alist-path-dispatcher
`(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(rooted-file-handler "/usr/local/etc/httpd/htdocs"
(make-file-directory-options))
(make-file-directory-options))))
;;; Greatest hits request handler.
@ -41,7 +44,9 @@
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(rooted-file-handler "/usr/local/etc/httpd/htdocs"
(make-file-directory-options))
(make-file-directory-options))))

View File

@ -12,7 +12,6 @@
(define-record-type httpd-options :httpd-options
(really-make-httpd-options port
root-directory
icon-name
fqdn
reported-port
request-handler
@ -26,14 +25,6 @@
set-httpd-options-port!)
(root-directory httpd-options-root-directory
set-httpd-options-root-directory!)
;; ICON-NAME specifies how to generate the links to
;; various decorative icons for the listings. It can either be a
;; procedure which gets passed one of the icon tags in TAG->ICON and
;; is expected to return a link pointing to the icon. If it is a
;; string, that is taken as prefix to which the names from TAG->ICON
;; are appended.
(icon-name httpd-options-icon-name
set-httpd-options-icon-name!)
(fqdn httpd-options-fqdn
set-httpd-options-fqdn!)
(reported-port httpd-options-reported-port
@ -52,7 +43,6 @@
(define (make-default-httpd-options)
(really-make-httpd-options 80 ; port
"/" ; root-directory
#f ; icon-name
#f ; fqdn
#f ; reported-port
#f ; request-handler
@ -73,8 +63,6 @@
(httpd-options-port options))
(set-httpd-options-root-directory! new-options
(httpd-options-root-directory options))
(set-httpd-options-icon-name! new-options
(httpd-options-icon-name options))
(set-httpd-options-fqdn! new-options
(httpd-options-fqdn options))
(set-httpd-options-reported-port! new-options
@ -108,8 +96,6 @@
(make-httpd-options-transformer set-httpd-options-port!))
(define with-root-directory
(make-httpd-options-transformer set-httpd-options-root-directory!))
(define with-icon-name
(make-httpd-options-transformer set-httpd-options-icon-name!))
(define with-fqdn
(make-httpd-options-transformer set-httpd-options-fqdn!))
(define with-reported-port

View File

@ -24,15 +24,17 @@ exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
(define rh
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options)))
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
(rooted-file-handler "/usr/local/etc/httpd/htdocs"
(make-file-directory-options))
(make-file-directory-options))))
;; Crank up a server on port 8001, first resetting our identity to
;; crank up a server on port 8001, first resetting our identity to
;; user "nobody". Initialise the request-invariant part of the CGI
;; env before starting.

View File

@ -217,7 +217,6 @@
(export make-httpd-options
with-port
with-root-directory
with-icon-name
with-fqdn
with-reported-port
with-request-handler
@ -313,7 +312,15 @@
(export home-dir-handler
tilde-home-dir-handler
rooted-file-handler
rooted-file-or-directory-handler))
rooted-file-or-directory-handler
make-file-directory-options
with-file-name->content-type
with-file-name->content-encoding
with-file-name->icon-file-name
with-blank-icon-file-name
with-back-icon-file-name
with-unknown-icon-file-name))
(define-interface httpd-seval-handlers-interface
(export seval-handler))
@ -661,6 +668,7 @@
(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
(open scheme-with-scsh
define-record-types
httpd-core
httpd-requests
httpd-responses