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

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
+\defun{tilde-home-dir-handler}{subdir default-request-handler options}{request-handler}
-  default-request-handler}{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

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
 ;;;     ~<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)
-				  req
+			     req
-				  "Path contains no home directory.")
+			     "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 packet)
-    ((errno/noent)
+       ((errno/noent)
-     (http-error (status-code not-found) req))
+	(http-error (status-code not-found) req))
-    ((errno/acces)
+       ((errno/acces)
-     (http-error (status-code forbidden) req)))
+	(http-error (status-code forbidden) req)))
-   (file-info fname #t)))
+    (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)
+(define (directory-index-serve-response fname file-path req options)
-  (file-serve-response (string-append fname "index.html") file-path req))
+  (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))
+			      directory-index-serve-response
-
+			      options))
-(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 "[   ]")))
 
 ;; 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)
+(define (default-file-name->icon-file-name fname)
-  (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)
   (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 ".z")) "compressed.xbm")
-     ((string-ci=? ext ".uu") 'uu)
+     ((string-ci=? ext ".uu") "uu.xbm")
-     ((string-ci=? ext ".hqx") 'binhex)
+     ((string-ci=? ext ".hqx") "binhex.xbm")
-     (else 'binary))))
+     (else "binary.xbm"))))
-
-(define (file-tag fname type)
-  (case type
-    ((regular fifo socket) (file-extension->tag fname))
-    ((directory) 'directory)
-    (else 'unknown)))
 
 (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 'src icon-name)
-		(cons 'alt (tag->alt tag)))
+		(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)
+	    (lambda (port httpd-options)
-	      (let* ((icon-option (httpd-options-icon-name options))
+	      (let ((back-icon
-		     (icon-name
+		     (file-directory-options-back-icon-file-name options))
-		      (cond
+		    (blank-icon
-		       ((procedure? icon-option) icon-option)
+		     (file-directory-options-blank-icon-file-name options)))
-		       ((string? icon-option)
-			(lambda (tag)
-			  (string-append icon-option (tag->icon tag))))
-		       (else tag->icon))))
 		(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 ]"))
+				  (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)
+	(file-serve-response index-fname file-path req options)
-	(directory-serve-response fname file-path req))))
+	(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 

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))))
 
 
 

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

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.
 

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