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}
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.
\var{Proc} takes a file name as an argument and must return a URL
for the corresponding icon or \sharpf.
\end{desc}
\defun{with-blank-icon-url}{file-name [options]}{options}
\defun{with-blank-icon-url}{file-name-or-\sharpf{} [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.
This specifies a file name (or its absence) 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-url}{file-name [options]}{options}
\defun{with-back-icon-url}{file-name-or-\sharpf{} [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.
This specifies a file name (or its absence) for the special icon
that is displayed next to the ``parent directory'' link in directory
listings.
\end{desc}
\defun{with-unknown-icon-url}{file-name [options]}{options}
\defun{with-unknown-icon-url}{file-name-or-\sharpf{}
[options]}{options}
\begin{desc}
This specifies a file name for the special icon that is displayed
next to the unknown entries in directory listings.
This specifies a file name (or its absence) 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
@ -529,7 +532,7 @@ of the options argument:
%
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}
This returns a request handler that serves files from a particular
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.
\end{desc}
\defun{rooted-file-or-directory-handler}{root options}{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 options}{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
@ -556,7 +559,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 options}{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

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

@ -37,10 +37,7 @@
(really-make-file-directory-options default-file-name->content-type
default-file-name->content-encoding
default-file-name->icon-url
"directory.xbm"
"blank.xbm"
"back.xbm"
"unknown.xbm"))
#f #f #f #f))
(define (copy-file-directory-options options)
(let ((new-options (make-default-file-directory-options)))
@ -117,19 +114,20 @@
;;; serving
;;; ~<user>/<user-public-dir>/<file-path>
(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.")
(make-rooted-file-path-response (string-append (http-homedir (car path) req)
"/"
user-public-dir)
(cdr path)
file-serve-response
req
options))))
(define (home-dir-handler user-public-dir . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path req)
(if (null? path)
(make-error-response (status-code bad-request)
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
options)))))
;;; (tilde-home-dir-handler user-public-dir default-request-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -143,38 +141,41 @@
(and (> (string-length head) 0)
(char=? (string-ref head 0) #\~)))))
(define (tilde-home-dir-handler user-public-dir default-handler options)
(make-predicate-handler
tilde-home-dir?
(lambda (path req)
(let* ((tilde-home (car path)) ; Yes.
(slen (string-length tilde-home))
(subdir (string-append
(http-homedir (substring tilde-home 1 slen) req)
"/"
user-public-dir)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req
options)))
default-handler))
(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
tilde-home-dir?
(lambda (path req)
(let* ((tilde-home (car path)) ; Yes.
(slen (string-length tilde-home))
(subdir (string-append
(http-homedir (substring tilde-home 1 slen) req)
"/"
user-public-dir)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req
options)))
default-handler)))
;;; 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
;;; past ROOT with ..'s.
(define (rooted-file-handler root options)
(lambda (path req)
(make-rooted-file-path-response root path file-serve-response req options)))
(define (rooted-file-handler root . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path 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 options)
(lambda (path req)
(make-rooted-file-path-response root path
file-serve-and-dir-response
req
options)))
(define (rooted-file-or-directory-handler root . maybe-options)
(let-optionals maybe-options ((options (make-default-file-directory-options)))
(lambda (path req)
(make-rooted-file-path-response root path
file-serve-and-dir-response
req
options))))
;;;; Support procs for the path handlers
@ -271,44 +272,8 @@
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 (default-file-name->icon-url fname)
(let ((ext (file-name-extension fname)))
(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"))))
#f)
(define (time->directory-index-date-string time)
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
@ -395,9 +360,11 @@
((regular fifo socket) "[FILE]")
((directory) "[DIR ]")
(else "[????]"))))
(emit-tag port 'img
(cons 'src icon-name)
(cons 'alt tag-name))
(if icon-name
(emit-tag port 'img
(cons 'src icon-name)
(cons 'alt tag-name))
(display tag-name port))
(with-tag port a ((href file))
(emit-file-name file))
(pad-file-name file)
@ -456,17 +423,21 @@
(with-tag port body ()
(emit-header port 1 title)
(with-tag port pre ()
(emit-tag port 'img
(cons 'src blank-icon)
(cons 'alt " "))
(if blank-icon
(display "[ ]" port)
(emit-tag port 'img
(cons 'src blank-icon)
(cons 'alt " ")))
(write-string "Name " port)
(write-string "Last modified " port)
(write-string "Size " port)
(write-string "Description" port)
(emit-tag port 'hr)
(emit-tag port 'img
(cons 'src back-icon)
(cons 'alt "[UP ]"))
(if back-icon
(emit-tag port 'img
(cons 'src back-icon)
(cons 'alt "[UP ]"))
(display "[UP ]" port))
(if (not (null? file-path))
(begin
(with-tag port a ((href ".."))

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

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

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
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html" (make-file-directory-options)))
`(("h" . ,(home-dir-handler "public_html"))
("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"
(make-file-directory-options))
(make-file-directory-options))))
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))

1
scheme/packages.scm
View File

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