486 lines
16 KiB
Scheme
486 lines
16 KiB
Scheme
;;; http server in the Scheme Shell -*- Scheme -*-
|
|
|
|
;;; 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.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
(define server/buffer-size 8192) ; WTF
|
|
|
|
;;; (home-dir-handler user-public-dir) -> handler
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Return a path handler that looks things up in a specific directory
|
|
;;; in the user's home directory. If ph = (home-dir-handler "public_html")
|
|
;;; then ph is a path-handler that serves files out of peoples' public_html
|
|
;;; subdirectory. So
|
|
;;; (ph '("shivers" "hk.html") req)
|
|
;;; will serve the file
|
|
;;; ~shivers/public_html/hk.html
|
|
;;; The path handler treats the URL path as (<user> . <file-path>),
|
|
;;; serving
|
|
;;; ~<user>/<user-public-dir>/<file-path>
|
|
|
|
(define (home-dir-handler user-public-dir)
|
|
(lambda (path req)
|
|
(if (null? path)
|
|
(make-http-error-response http-status/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))))
|
|
|
|
;;; (tilde-home-dir-handler user-public-dir default-path-handler)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
|
|
;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
|
|
;;; default handler.
|
|
|
|
(define (tilde-home-dir? path req)
|
|
(and (not (null? path))
|
|
(let ((head (car path))) ; home-directory path?
|
|
(and (> (string-length head) 0)
|
|
(char=? (string-ref head 0) #\~)))))
|
|
|
|
(define (tilde-home-dir-handler user-public-dir default-ph)
|
|
(make-request-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)))
|
|
default-ph))
|
|
|
|
|
|
;;; 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)
|
|
(lambda (path req)
|
|
(make-rooted-file-path-response root path file-serve-response req)))
|
|
|
|
;;; Dito, but also serve directory indices for directories without
|
|
;;; index.html.
|
|
|
|
(define (rooted-file-or-directory-handler root)
|
|
(lambda (path req)
|
|
(make-rooted-file-path-response root path
|
|
file-serve-and-dir-response
|
|
req)))
|
|
|
|
|
|
;;;; Support procs for the path handlers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Do a request for a file. The file-name is determined by appending the
|
|
;;; the FILE-PATH list the string ROOT. E.g., if
|
|
;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html")
|
|
;;; then we serve file
|
|
;;; /usr/shivers/a/b/c/foo.html
|
|
;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
|
|
;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path
|
|
;;; sequences are processed away by the browser when the URI is converted
|
|
;;; to an absolute URI before it is sent off to the server.)
|
|
;;; It is possible to sneak a .. past this kind of front-end resolving by
|
|
;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
|
|
;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction.
|
|
;;; So you cannot make the reference back up past ROOT. E.g., this is
|
|
;;; not allowed:
|
|
;;; FILE-PATH = ("a" "../.." "c" "foo.html")
|
|
;;;
|
|
;;; Only GET and HEAD ops are provided.
|
|
;;; The URL's <search> component must be #f.
|
|
;;; The file is served if the server has read or stat(2) access to it,
|
|
;;; respectively. If the server is run as root, this might be a problem.
|
|
;;;
|
|
;;; FILE-SERVE is a procedure which gets passed the file name, the
|
|
;;; path, and the HTTP request to serve the file propert after the
|
|
;;; 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)
|
|
(if (http-url:search (request:url req))
|
|
(make-http-error-response http-status/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)))
|
|
(else
|
|
(make-http-error-response http-status/bad-request req
|
|
"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 http-status/not-found req))
|
|
((errno/acces)
|
|
(http-error http-status/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)
|
|
(if (file-name-directory? fname) ; Simple index generation.
|
|
(directory-serve-response fname file-path req)
|
|
|
|
(let ((request-method (request:method req)))
|
|
(cond
|
|
((or (string=? request-method "GET")
|
|
(string=? request-method "HEAD")) ; Absolutely.
|
|
(let ((info (stat-carefully fname req)))
|
|
(case (file-info:type info)
|
|
|
|
((regular fifo socket)
|
|
(send-file-response fname info req))
|
|
|
|
((directory) ; Send back a redirection "foo" -> "foo/"
|
|
(make-http-error-response
|
|
http-status/moved-perm req
|
|
(string-append (request:uri req) "/")
|
|
(string-append (http-url->string (request:url req))
|
|
"/")))
|
|
|
|
(else (make-http-error-response http-status/forbidden req)))))
|
|
|
|
(else
|
|
(make-http-error-response http-status/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 (file-serve-response fname file-path req)
|
|
(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 "[ ]")))
|
|
|
|
;; 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)
|
|
(let ((ext (file-name-extension fname)))
|
|
(cond
|
|
((string-ci=? ext ".txt") 'text)
|
|
((or (string-ci=? ext ".doc")
|
|
(string-ci=? ext ".html")
|
|
(string-ci=? ext ".rtf")
|
|
(string-ci=? ext ".tex")) 'doc)
|
|
((or (string-ci=? ext ".gif")
|
|
(string-ci=? ext ".jpg")
|
|
(string-ci=? ext ".jpeg")
|
|
(string-ci=? ext ".tiff")
|
|
(string-ci=? ext ".tif")) 'image)
|
|
((or (string-ci=? ext ".mpeg")
|
|
(string-ci=? ext ".mpg")) 'movie)
|
|
((or (string-ci=? ext ".au")
|
|
(string-ci=? ext ".snd")
|
|
(string-ci=? ext ".wav")) 'audio)
|
|
((or (string-ci=? ext ".tar")
|
|
(string-ci=? ext ".zip")
|
|
(string-ci=? ext ".zoo")) 'archive)
|
|
((or (string-ci=? ext ".gz")
|
|
(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)))
|
|
|
|
(define (time->directory-index-date-string time)
|
|
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
|
|
|
(define (read-max-lines fname max)
|
|
(call-with-input-file
|
|
fname
|
|
(lambda (port)
|
|
(let loop ((r "") (i max))
|
|
(if (zero? i)
|
|
r
|
|
(let ((line (read-line port)))
|
|
(if (eof-object? line)
|
|
r
|
|
(loop (string-append r " " line) (- i 1)))))))))
|
|
|
|
(define (string-cut s n)
|
|
(if (>= (string-length s) n)
|
|
(substring s 0 n)
|
|
s))
|
|
|
|
(define html-file-header
|
|
(let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
|
|
(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
|
|
(lambda (fname n)
|
|
(let ((stuff (read-max-lines fname 10)))
|
|
(cond
|
|
((regexp-exec title-tag-regexp stuff)
|
|
=> (lambda (open-match)
|
|
(cond
|
|
((regexp-exec title-close-tag-regexp stuff
|
|
(match:end open-match 0))
|
|
=> (lambda (close-match)
|
|
(string-cut (substring stuff
|
|
(match:end open-match 0)
|
|
(match:start close-match 0))
|
|
n)))
|
|
(else (string-cut (substring stuff
|
|
(match:end open-match 0)
|
|
(string-length stuff))
|
|
n)))))
|
|
(else ""))))))
|
|
|
|
(define (file-documentation fname n)
|
|
(cond
|
|
((file-extension->content-type fname)
|
|
=> (lambda (content-type)
|
|
(if (and (string=? content-type "text/html" )
|
|
(file-readable? fname))
|
|
(html-file-header fname n)
|
|
"")))
|
|
(else "")))
|
|
|
|
(define (directory-index req dir icon-name port)
|
|
|
|
(define (pad-file-name file)
|
|
(write-string (make-string (max (- 21 (string-length file))
|
|
1)
|
|
#\space)
|
|
port))
|
|
|
|
(define (emit-file-name file)
|
|
(let ((l (string-length file)))
|
|
(if (<= l 20)
|
|
(emit-text file port)
|
|
(emit-text (substring file 0 20) port))))
|
|
|
|
(define (index-entry file)
|
|
(let* ((fname (directory-as-file-name (string-append dir file)))
|
|
(info (file-info fname #t))
|
|
(type (file-info:type info))
|
|
(size (file-info:size info))
|
|
(tag (file-tag file type)))
|
|
(emit-tag port 'img
|
|
(cons 'src (icon-name tag))
|
|
(cons 'alt (tag->alt tag)))
|
|
(with-tag port a ((href file))
|
|
(emit-file-name file))
|
|
(pad-file-name file)
|
|
(emit-text (time->directory-index-date-string (file-info:mtime info)) port)
|
|
(if size
|
|
(let* ((size-string
|
|
(string-append (number->string (quotient size 1024))
|
|
"K"))
|
|
(size-string
|
|
(if (<= (string-length size-string) 7)
|
|
size-string
|
|
(string-append (number->string (quotient size (* 1024 1024)))
|
|
"M")))
|
|
(size-string
|
|
(if (<= (string-length size-string) 8)
|
|
(string-append
|
|
(make-string (- 8 (string-length size-string)) #\space)
|
|
size-string)
|
|
size-string)))
|
|
(write-string size-string port))
|
|
(write-string (make-string 8 #\space) port))
|
|
(write-char #\space port)
|
|
(emit-text (file-documentation fname 24) port)
|
|
(write-crlf port)))
|
|
|
|
(let ((files (directory-files dir)))
|
|
(for-each index-entry files)
|
|
(length files)))
|
|
|
|
(define (directory-serve-response fname file-path req)
|
|
(let ((request-method (request:method req)))
|
|
(cond
|
|
((or (string=? request-method "GET")
|
|
(string=? request-method "HEAD"))
|
|
|
|
(if (not (eq? 'directory
|
|
(file-info:type (file-info fname #t))))
|
|
(make-http-error-response http-status/forbidden req)
|
|
(make-response
|
|
http-status/ok
|
|
(status-code->text http-status/ok)
|
|
(time)
|
|
"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))))
|
|
(with-tag port html ()
|
|
(let ((title (string-append "Index of /"
|
|
(string-join file-path "/"))))
|
|
(with-tag port head ()
|
|
(emit-title port title))
|
|
(with-tag port body ()
|
|
(emit-header port 1 title)
|
|
(with-tag port pre ()
|
|
(emit-tag port 'img
|
|
(cons 'src (icon-name 'blank))
|
|
(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 (icon-name 'back))
|
|
(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)))
|
|
(emit-tag port 'hr)
|
|
(format port "~d files" n-files))))))))))))
|
|
(else
|
|
(make-http-error-response http-status/method-not-allowed req
|
|
request-method)))))
|
|
|
|
(define (index-or-directory-serve-response fname file-path req)
|
|
(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))))
|
|
|
|
(define (file-serve-and-dir-response fname file-path req)
|
|
(file-serve-or-dir-response fname file-path req
|
|
index-or-directory-serve-response))
|
|
|
|
;;; Look up user's home directory, generating an HTTP error response if you lose.
|
|
|
|
(define (http-homedir username req)
|
|
(with-fatal-error-handler (lambda (c decline)
|
|
(apply http-error http-status/bad-request req
|
|
"Couldn't find user's home directory."
|
|
(condition-stuff c)))
|
|
|
|
(home-dir username)))
|
|
|
|
|
|
(define (send-file-response filename info req)
|
|
(if (file-not-readable? filename) ; #### double stats are no good
|
|
(make-http-error-response http-status/not-found req)
|
|
(receive (stripped-filename content-encoding)
|
|
(file-extension->content-encoding filename)
|
|
(make-response http-status/ok
|
|
(status-code->text http-status/ok)
|
|
(time)
|
|
(file-extension->content-type stripped-filename)
|
|
(append (if content-encoding
|
|
(cons 'content-encoding content-encoding)
|
|
'())
|
|
(list
|
|
(cons 'last-modified
|
|
(time->http-date-string
|
|
(file-info:mtime info)))
|
|
(cons 'content-length (file-info:size info))))
|
|
(make-writer-body
|
|
(lambda (port options)
|
|
(call-with-input-file filename
|
|
(lambda (in)
|
|
(copy-inport->outport in port)))))))))
|
|
|
|
|
|
(define (file-extension->content-type fname)
|
|
(let ((ext (file-name-extension fname)))
|
|
(cond
|
|
((string-ci=? ext ".html") "text/html")
|
|
((string-ci=? ext ".txt") "text/plain")
|
|
((string-ci=? ext ".gif") "image/gif")
|
|
((string-ci=? ext ".png") "image/png")
|
|
((or (string-ci=? ext ".jpg")
|
|
(string-ci=? ext ".jpeg")) "image/jpeg")
|
|
((or (string-ci=? ext ".tiff")
|
|
(string-ci=? ext ".tif")) "image/tif")
|
|
((string-ci=? ext ".rtf") "text/rtf")
|
|
((or (string-ci=? ext ".mpeg")
|
|
(string-ci=? ext ".mpg")) "video/mpeg")
|
|
((or (string-ci=? ext ".au")
|
|
(string-ci=? ext ".snd")) "audio/basic")
|
|
((string-ci=? ext ".wav") "audio/x-wav")
|
|
((string-ci=? ext ".dvi") "application/x-dvi")
|
|
((or (string-ci=? ext ".tex")
|
|
(string-ci=? ext ".latex")) "application/latex")
|
|
((string-ci=? ext ".zip") "application/zip")
|
|
((string-ci=? ext ".tar") "application/tar")
|
|
((string-ci=? ext ".ps") "application/postscript")
|
|
((string-ci=? ext ".pdf") "application/pdf")
|
|
(else "application/octet-stream"))))
|
|
|
|
(define (file-extension->content-encoding fname)
|
|
(cond
|
|
((let ((ext (file-name-extension fname)))
|
|
(cond
|
|
((string-ci=? ext ".Z") "x-compress")
|
|
((string-ci=? ext ".gz") "x-gzip")
|
|
(else #f)))
|
|
=> (lambda (encoding)
|
|
(values (file-name-sans-extension fname) encoding)))
|
|
(else (values fname #f))))
|
|
|