scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- Make the handlers in HTTPD-FILE-DIRECTORY-HANDLERS do something 

sensible without a set of icons.
- Make the options arguments to the handlers in
  HTTPD-FILE-DIRECTORY-HANDLERS optional.
This commit is contained in:
sperber 2003-01-29 10:08:25 +00:00
parent 730053c6bc
commit 6e5f9ed278
5 changed files with 81 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
doc/latex/httpd.tex
View File

@ -493,26 +493,29 @@ one. Here they are:
\begin{desc} \begin{desc}
This specifies a procedure for determining the icon to be displayed This specifies a procedure for determining the icon to be displayed
next to a file name in a directory listing. next to a file name in a directory listing.
\var{Proc} takes a file name as an argument and must return a URI \var{Proc} takes a file name as an argument and must return a URL
representing the corresponding icon. for the corresponding icon or \sharpf.
\end{desc} \end{desc}
\defun{with-blank-icon-url}{file-name [options]}{options} \defun{with-blank-icon-url}{file-name-or-\sharpf{} [options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that must be as wide This specifies a file name (or its absence) for the special icon
as the icons returned by the previous procedure but that is blank. that must be as wide as the icons returned by the previous procedure
but that is blank.
\end{desc} \end{desc}
\defun{with-back-icon-url}{file-name [options]}{options} \defun{with-back-icon-url}{file-name-or-\sharpf{} [options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that is displayed This specifies a file name (or its absence) for the special icon
next to the ``parent directory'' link in directory listings. that is displayed next to the ``parent directory'' link in directory
listings.
\end{desc} \end{desc}
\defun{with-unknown-icon-url}{file-name [options]}{options} \defun{with-unknown-icon-url}{file-name-or-\sharpf{}
[options]}{options}
\begin{desc} \begin{desc}
This specifies a file name for the special icon that is displayed This specifies a file name (or its absence) for the special icon
next to the unknown entries in directory listings. that is displayed next to the unknown entries in directory listings.
\end{desc} \end{desc}
The \ex{make-file-directory-options} procedure eases the construction The \ex{make-file-directory-options} procedure eases the construction
@ -529,7 +532,7 @@ of the options argument:
% %
Here are procedure for constructing static content request handlers: Here are procedure for constructing static content request handlers:
% %
\defun{rooted-file-handler}{root options}{request-handler} \defun{rooted-file-handler}{root [options]}{request-handler}
\begin{desc} \begin{desc}
This returns a request handler that serves files from a particular This returns a request handler that serves files from a particular
root in the file system. Only the \ex{GET} operation is provided. root in the file system. Only the \ex{GET} operation is provided.
@ -539,13 +542,13 @@ Here are procedure for constructing static content request handlers:
Otherwise, the file is served to the client. Otherwise, the file is served to the client.
\end{desc} \end{desc}
\defun{rooted-file-or-directory-handler}{root options}{request-handler} \defun{rooted-file-or-directory-handler}{root [options]}{request-handler}
\begin{desc} \begin{desc}
Dito, but also serve directory indices for directories without Dito, but also serve directory indices for directories without
\ex{index.html}. \ex{index.html}.
\end{desc} \end{desc}
\defun{home-dir-handler}{subdir options}{request-handler} \defun{home-dir-handler}{subdir [options]}{request-handler}
\begin{desc} \begin{desc}
This procedure builds a request handler that does basic file serving This procedure builds a request handler that does basic file serving
out of home directories. If the resulting \var{request-handler} is out of home directories. If the resulting \var{request-handler} is
@ -556,7 +559,7 @@ Dito, but also serve directory indices for directories without
allowed to contain \ex{..} elements. allowed to contain \ex{..} elements.
\end{desc} \end{desc}
\defun{tilde-home-dir-handler}{subdir default-request-handler options}{request-handler} \defun{tilde-home-dir-handler}{subdir default-request-handler [options]}{request-handler}
\begin{desc} \begin{desc}
This returns request handler that examines the car of the path. If 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 it is a string beginning with a tilde, e.g., \ex{"~ziggy"}, then the

71
scheme/httpd/file-dir-handler.scm
View File

@ -37,10 +37,7 @@
(really-make-file-directory-options default-file-name->content-type (really-make-file-directory-options default-file-name->content-type
default-file-name->content-encoding default-file-name->content-encoding
default-file-name->icon-url default-file-name->icon-url
"directory.xbm" #f #f #f #f))
"blank.xbm"
"back.xbm"
"unknown.xbm"))
(define (copy-file-directory-options options) (define (copy-file-directory-options options)
(let ((new-options (make-default-file-directory-options))) (let ((new-options (make-default-file-directory-options)))
@ -117,7 +114,8 @@
;;; serving ;;; serving
;;; ~<user>/<user-public-dir>/<file-path> ;;; ~<user>/<user-public-dir>/<file-path>
(define (home-dir-handler user-public-dir options) (define (home-dir-handler user-public-dir . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path req) (lambda (path req)
(if (null? path) (if (null? path)
(make-error-response (status-code bad-request) (make-error-response (status-code bad-request)
@ -129,7 +127,7 @@
(cdr path) (cdr path)
file-serve-response file-serve-response
req req
options)))) options)))))
;;; (tilde-home-dir-handler user-public-dir default-request-handler) ;;; (tilde-home-dir-handler user-public-dir default-request-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -143,7 +141,8 @@
(and (> (string-length head) 0) (and (> (string-length head) 0)
(char=? (string-ref head 0) #\~))))) (char=? (string-ref head 0) #\~)))))
(define (tilde-home-dir-handler user-public-dir default-handler options) (define (tilde-home-dir-handler user-public-dir default-handler . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(make-predicate-handler (make-predicate-handler
tilde-home-dir? tilde-home-dir?
(lambda (path req) (lambda (path req)
@ -155,26 +154,28 @@
user-public-dir))) 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))) options)))
default-handler)) default-handler)))
;;; Make a handler that serves files relative to a particular root ;;; Make a handler that serves files relative to a particular root
;;; in the file system. You may follow symlinks, but you can't back up ;;; in the file system. You may follow symlinks, but you can't back up
;;; past ROOT with ..'s. ;;; past ROOT with ..'s.
(define (rooted-file-handler root options) (define (rooted-file-handler root . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path req) (lambda (path req)
(make-rooted-file-path-response root path file-serve-response req options))) (make-rooted-file-path-response root path file-serve-response req options))))
;;; Dito, but also serve directory indices for directories without ;;; Dito, but also serve directory indices for directories without
;;; index.html. ;;; index.html.
(define (rooted-file-or-directory-handler root options) (define (rooted-file-or-directory-handler root . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path req) (lambda (path req)
(make-rooted-file-path-response root path (make-rooted-file-path-response root path
file-serve-and-dir-response file-serve-and-dir-response
req req
options))) options))))
;;;; Support procs for the path handlers ;;;; Support procs for the path handlers
@ -271,44 +272,8 @@
directory-index-serve-response directory-index-serve-response
options)) options))
;; These icons can, for example, be found in the cern-httpd-3.0
;; distribution at http://www.w3.org/pub/WWW/Daemon/
(define (default-file-name->icon-url fname) (define (default-file-name->icon-url fname)
(let ((ext (file-name-extension fname))) #f)
(cond
((string-ci=? ext ".txt") "text.xbm")
((or (string-ci=? ext ".doc")
(string-ci=? ext ".htm")
(string-ci=? ext ".html")
(string-ci=? ext ".rtf")
(string-ci=? ext ".pdf")
(string-ci=? ext ".dvi")
(string-ci=? ext ".ps")
(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.xbm")
((or (string-ci=? ext ".mpeg")
(string-ci=? ext ".mpg")) "movie.xbm")
((or (string-ci=? ext ".au")
(string-ci=? ext ".snd")
(string-ci=? ext ".mp3")
(string-ci=? ext ".wav")) "sound.xbm")
((or (string-ci=? ext ".tar")
(string-ci=? ext ".zip")
(string-ci=? ext ".zoo")) "tar.xbm")
((or (string-ci=? ext ".gz")
(string-ci=? ext ".bz2")
(string-ci=? ext ".Z")
(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) (define (time->directory-index-date-string time)
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0))) (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
@ -395,9 +360,11 @@
((regular fifo socket) "[FILE]") ((regular fifo socket) "[FILE]")
((directory) "[DIR ]") ((directory) "[DIR ]")
(else "[????]")))) (else "[????]"))))
(if icon-name
(emit-tag port 'img (emit-tag port 'img
(cons 'src icon-name) (cons 'src icon-name)
(cons 'alt tag-name)) (cons 'alt tag-name))
(display tag-name port))
(with-tag port a ((href file)) (with-tag port a ((href file))
(emit-file-name file)) (emit-file-name file))
(pad-file-name file) (pad-file-name file)
@ -456,17 +423,21 @@
(with-tag port body () (with-tag port body ()
(emit-header port 1 title) (emit-header port 1 title)
(with-tag port pre () (with-tag port pre ()
(if blank-icon
(display "[ ]" port)
(emit-tag port 'img (emit-tag port 'img
(cons 'src blank-icon) (cons 'src blank-icon)
(cons 'alt " ")) (cons 'alt " ")))
(write-string "Name " port) (write-string "Name " port)
(write-string "Last modified " port) (write-string "Last modified " port)
(write-string "Size " port) (write-string "Size " port)
(write-string "Description" port) (write-string "Description" port)
(emit-tag port 'hr) (emit-tag port 'hr)
(if back-icon
(emit-tag port 'img (emit-tag port 'img
(cons 'src back-icon) (cons 'src back-icon)
(cons 'alt "[UP ]")) (cons 'alt "[UP ]"))
(display "[UP ]" port))
(if (not (null? file-path)) (if (not (null? file-path))
(begin (begin
(with-tag port a ((href "..")) (with-tag port a ((href ".."))

13
scheme/httpd/http-top.scm
View File

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

6
scheme/httpd/server.scm
View File

@ -24,13 +24,11 @@ exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
(define rh (define rh
(alist-path-dispatcher (alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options))) `(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler) ("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))) ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html" (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))))

1
scheme/packages.scm
View File

@ -680,6 +680,7 @@
(subset rfc822 (rfc822-time->string)) (subset rfc822 (rfc822-time->string))
sunet-utilities ; dotdot-check, copy-inport->outport sunet-utilities ; dotdot-check, copy-inport->outport
conditions conditions
let-opt
handle-fatal-error handle-fatal-error
) )
(files (httpd file-dir-handler))) (files (httpd file-dir-handler)))