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
parent
eb20aec688
commit
022ea25ba6
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue