diff --git a/doc/latex/httpd.tex b/doc/latex/httpd.tex index f278027..5ae25a6 100644 --- a/doc/latex/httpd.tex +++ b/doc/latex/httpd.tex @@ -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 diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm index c804598..2301263 100644 --- a/scheme/httpd/file-dir-handler.scm +++ b/scheme/httpd/file-dir-handler.scm @@ -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,18 +117,19 @@ ;;; serving ;;; ~// -(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) - req - "Path contains no home directory.") + req + "Path contains no home directory.") (make-rooted-file-path-response (string-append (http-homedir (car path) req) "/" 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,36 +209,36 @@ ;;; 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.") + "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."))))) + "URL contains unresolvable ..'s."))))) ;; Just (file-info fname) with error handling. (define (stat-carefully fname req) (with-errno-handler - ((errno packet) - ((errno/noent) - (http-error (status-code not-found) req)) - ((errno/acces) - (http-error (status-code forbidden) req))) - (file-info fname #t))) + ((errno packet) + ((errno/noent) + (http-error (status-code not-found) req)) + ((errno/acces) + (http-error (status-code forbidden) req))) + (file-info fname #t))) ;;; A basic file request handler -- ship the dude the file. No fancy path ;;; 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 @@ -163,54 +261,23 @@ (else (make-error-response (status-code method-not-allowed) req - request-method)))))) + 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 'alt "[UP ]")) + (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))))) + 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 diff --git a/scheme/httpd/http-top.scm b/scheme/httpd/http-top.scm index 908f064..18f0a85 100644 --- a/scheme/httpd/http-top.scm +++ b/scheme/httpd/http-top.scm @@ -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)))) diff --git a/scheme/httpd/options.scm b/scheme/httpd/options.scm index 24ec38a..6b37996 100644 --- a/scheme/httpd/options.scm +++ b/scheme/httpd/options.scm @@ -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 diff --git a/scheme/httpd/server.scm b/scheme/httpd/server.scm index 7364f99..ba017a9 100755 --- a/scheme/httpd/server.scm +++ b/scheme/httpd/server.scm @@ -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. diff --git a/scheme/packages.scm b/scheme/packages.scm index d2382d8..dea441d 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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