538 lines
18 KiB
Scheme
538 lines
18 KiB
Scheme
;;; http server in the Scheme Shell -*- Scheme -*-
|
|
;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
|
|
|
|
;;; Imports and non-R4RS'isms
|
|
;;; scsh syscalls
|
|
;;; format Formatted output
|
|
;;; ?, UNLESS, SWITCH Conditionals
|
|
;;; httpd-core stuff
|
|
;;; httpd error stuff
|
|
;;; CONDITION-STUFF Scheme 48 error conditions
|
|
;;; url stuff
|
|
|
|
;;; Path handlers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Path handlers are the guys that actually perform the requested operation
|
|
;;; on the URL. The handler interface is
|
|
;;; (handler path-list request)
|
|
;;; The path-list is a URL path list that is a suffix of REQUEST's url's
|
|
;;; path-list. Path handlers can decide how to handle an operation by
|
|
;;; recursively keying off of the elements in path-list.
|
|
;;;
|
|
;;; The object-oriented view:
|
|
;;; One way to look at this is to think of the request's METHOD as a
|
|
;;; generic operation on the URL. Recursive path handlers do method
|
|
;;; lookup to determine how to implement a given operation on a particular
|
|
;;; path.
|
|
;;;
|
|
;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
|
|
;;; the details of the client request. However, path handlers should *not*
|
|
;;; read the request entity from, or write the reply to the request's socket.
|
|
;;; Path-handler I/O should be done on the current i/o ports: if the handler
|
|
;;; needs to read an entity, it should read it from (CURRENT-INPUT-PORT); when
|
|
;;; the handler wishes to write a reply, it should write it to
|
|
;;; (CURRENT-OUTPUT-PORT). This makes it easy for the procedure that called
|
|
;;; the handler to establish I/O indirections or filters if it so desires.
|
|
;;;
|
|
;;; This file implements a basic set of path handlers and some useful
|
|
;;; support procedures for them.
|
|
|
|
|
|
(define server/buffer-size 8192) ; WTF
|
|
|
|
|
|
;;; (alist-path-dispatcher hander-alist default-handler) -> handler
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; This function creates a table-driven path-handler that dispatches off
|
|
;;; of the car of the request path. The handler uses the car to index into
|
|
;;; a path-handler alist. If it finds a hit, it recurses using the table's
|
|
;;; path-handler. If no hits, it handles the path with a default handler.
|
|
;;; An alist handler is passed the tail of the original path; the
|
|
;;; default handler gets the entire original path.
|
|
;;;
|
|
;;; This procedure is how you say: "If the first element of the URL's
|
|
;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z."
|
|
|
|
(define (alist-path-dispatcher handler-alist default-handler)
|
|
(lambda (path req)
|
|
(cond ((and (pair? path) (assoc (car path) handler-alist)) =>
|
|
(lambda (entry) ((cdr entry) (cdr path) req)))
|
|
(else (default-handler path req)))))
|
|
|
|
|
|
;;; (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 (pair? path)
|
|
(serve-rooted-file-path (string-append (http-homedir (car path) req)
|
|
"/"
|
|
user-public-dir)
|
|
(cdr path)
|
|
file-serve
|
|
req)
|
|
(http-error http-reply/bad-request req
|
|
"Path contains no home directory."))))
|
|
|
|
;;; (tilde-home-dir-handler user-public-dir default)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; 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-handler user-public-dir default-ph)
|
|
(lambda (path req)
|
|
(if (and (pair? path) ; Is it a ~foo/...
|
|
(let ((head (car path))) ; home-directory path?
|
|
(and (> (string-length head) 0)
|
|
(char=? (string-ref head 0) #\~))))
|
|
|
|
(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)))
|
|
(serve-rooted-file-path subdir (cdr path) file-serve req))
|
|
|
|
(default-ph path req)))) ; No.
|
|
|
|
|
|
;;; 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)
|
|
(serve-rooted-file-path root path file-serve req)))
|
|
|
|
;;; Dito, but also serve directory indices for directories without
|
|
;;; index.html. ICON-NAME specifies how to generate the links to
|
|
;;; various decorative icons for the listings. It can either be a
|
|
;;; prcoedure 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.
|
|
|
|
(define (rooted-file-or-directory-handler root icon-name)
|
|
(let ((file-serve-and-dir (file-server-and-dir icon-name)))
|
|
(lambda (path req)
|
|
(serve-rooted-file-path root path file-serve-and-dir req))))
|
|
|
|
|
|
;;; The null path handler -- handles nothing, sends back an error reply.
|
|
;;; Can be useful as the default in table-driven path handlers.
|
|
|
|
(define (null-path-handler path req)
|
|
(http-error http-reply/not-found req))
|
|
|
|
|
|
;;;; Support procs for the path handlers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;; (SERVE-ROOTED-FILE-PATH 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, SERVE-ROOTED-FILE-PATH 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 (serve-rooted-file-path root file-path file-serve req)
|
|
(if (http-url:search (request:url req))
|
|
(http-error http-reply/bad-request req
|
|
"Indexed search not provided for this URL.")
|
|
|
|
(cond ((dotdot-check root file-path) =>
|
|
(lambda (fname) (file-serve fname file-path req)))
|
|
(else
|
|
(http-error http-reply/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-reply/not-found req))
|
|
((errno/acces)
|
|
(http-error http-reply/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 fname file-path req directory-serve)
|
|
(if (file-name-directory? fname) ; Simple index generation.
|
|
(directory-serve fname file-path req)
|
|
|
|
(switch string=? (request:method req)
|
|
(("GET" "HEAD") ; Absolutely.
|
|
(let ((info (stat-carefully fname req)))
|
|
(case (file-info:type info)
|
|
|
|
((regular fifo socket)
|
|
(send-file fname info req))
|
|
|
|
((directory) ; Send back a redirection "foo" -> "foo/"
|
|
(http-error http-reply/moved-perm req
|
|
(string-append (request:uri req) "/")
|
|
(string-append (http-url->string (request:url req))
|
|
"/")))
|
|
|
|
(else (http-error http-reply/forbidden req)))))
|
|
|
|
(else (http-error http-reply/method-not-allowed req)))))
|
|
|
|
(define (directory-index-serve fname file-path req)
|
|
(file-serve (string-append fname "index.html") file-path req))
|
|
|
|
(define (file-serve fname file-path req)
|
|
(file-serve-or-dir fname file-path req directory-index-serve))
|
|
|
|
(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)
|
|
(switch string-ci=? (file-name-extension fname)
|
|
((".txt") 'text)
|
|
((".doc" ".html" ".rtf" ".tex") 'doc)
|
|
((".gif" ".jpg" ".jpeg" ".tiff" ".tif") 'image)
|
|
((".mpeg" ".mpg") 'movie)
|
|
((".au" ".snd" ".wav") 'audio)
|
|
((".tar" ".zip" ".zoo") 'archive)
|
|
((".gz" ".Z" ".z") 'compressed)
|
|
((".uu") 'uu)
|
|
((".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)
|
|
|
|
(define (pad-file-name file)
|
|
(write-string (make-string (- 21 (string-length file))
|
|
#\space)))
|
|
|
|
(define (emit-file-name file)
|
|
(let ((l (string-length file)))
|
|
(if (<= l 20)
|
|
(emit-text file)
|
|
(emit-text (substring file 0 20)))))
|
|
|
|
(define (index-entry file)
|
|
(let* ((fname (directory-as-file-name (string-append dir file)))
|
|
(info (stat-carefully fname req))
|
|
(type (file-info:type info))
|
|
(size (file-info:size info))
|
|
(tag (file-tag file type)))
|
|
(emit-tag #t 'img
|
|
(cons 'src (icon-name tag))
|
|
(cons 'alt (tag->alt tag)))
|
|
(with-tag #t a ((href file))
|
|
(emit-file-name file))
|
|
(pad-file-name file)
|
|
(emit-text (time->directory-index-date-string (file-info:mtime info)))
|
|
(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))
|
|
(write-string (make-string 8 #\space)))
|
|
(write-char #\space)
|
|
(emit-text (file-documentation fname 24))
|
|
(newline)))
|
|
|
|
(let ((files (with-errno-handler
|
|
((errno packet)
|
|
((errno/acces)
|
|
(http-error http-reply/forbidden req)))
|
|
(directory-files dir))))
|
|
(for-each index-entry files)
|
|
(length files)))
|
|
|
|
(define (directory-server icon-name)
|
|
(let ((icon-name
|
|
(cond
|
|
((procedure? icon-name) icon-name)
|
|
((string? icon-name)
|
|
(lambda (tag)
|
|
(string-append icon-name (tag->icon tag))))
|
|
(else tag->icon))))
|
|
(lambda (fname file-path req)
|
|
(switch string=? (request:method req)
|
|
(("GET" "HEAD")
|
|
|
|
(unless (eq? 'directory (file-info:type (stat-carefully fname req)))
|
|
(http-error http-reply/forbidden req))
|
|
|
|
(unless (v0.9-request? req)
|
|
(begin-http-header #t http-reply/ok)
|
|
(write-string "Content-type: text/html\r\n")
|
|
(write-string "\r\n"))
|
|
|
|
(with-tag #t html ()
|
|
(let ((title (string-append "Index of /"
|
|
(join-strings file-path "/"))))
|
|
(with-tag #t head ()
|
|
(emit-title #t title))
|
|
(with-tag #t body ()
|
|
(emit-header #t 1 title)
|
|
(with-tag #t pre ()
|
|
(emit-tag #t 'img
|
|
(cons 'src (icon-name 'blank))
|
|
(cons 'alt " "))
|
|
(write-string "Name ")
|
|
(write-string "Last modified ")
|
|
(write-string "Size ")
|
|
(write-string "Description")
|
|
(emit-tag #t 'hr)
|
|
(emit-tag #t 'img
|
|
(cons 'src (icon-name 'back))
|
|
(cons 'alt "[UP ]"))
|
|
(unless (null? file-path)
|
|
(with-tag #t a ((href ".."))
|
|
(write-string "Parent directory"))
|
|
(newline))
|
|
(let ((n-files (directory-index req fname icon-name)))
|
|
(emit-tag #t 'hr)
|
|
(format #t "~d files" n-files)))))))
|
|
(else (http-error http-reply/method-not-allowed req))))))
|
|
|
|
(define (index-or-directory-server icon-name)
|
|
(let ((directory-serve (directory-server icon-name)))
|
|
(lambda (fname file-path req)
|
|
(let ((index-fname (string-append fname "index.html")))
|
|
|
|
(if (file-readable? index-fname)
|
|
(file-serve index-fname file-path req)
|
|
(directory-serve fname file-path req))))))
|
|
|
|
(define (file-server-and-dir icon-name)
|
|
(let ((index-or-directory-serve (index-or-directory-server icon-name)))
|
|
(lambda (fname file-path req)
|
|
(file-serve-or-dir fname file-path req index-or-directory-serve))))
|
|
|
|
;;; Look up user's home directory, generating an HTTP error reply if you lose.
|
|
|
|
(define (http-homedir username req)
|
|
(with-fatal-error-handler (lambda (c decline)
|
|
(apply http-error http-reply/bad-request req
|
|
"Couldn't find user's home directory."
|
|
(condition-stuff c)))
|
|
|
|
(home-dir username)))
|
|
|
|
|
|
(define (send-file filename info req)
|
|
(with-errno-handler ((errno packet)
|
|
((errno/acces)
|
|
(http-error http-reply/forbidden req))
|
|
((errno/noent)
|
|
(http-error http-reply/not-found req)))
|
|
(call-with-input-file filename
|
|
(lambda (in)
|
|
(let ((out (current-output-port)))
|
|
(unless (v0.9-request? req)
|
|
(begin-http-header out http-reply/ok)
|
|
(receive (filename content-encoding)
|
|
(file-extension->content-encoding filename)
|
|
(if content-encoding
|
|
(format out "Content-encoding: ~A\r~%" content-encoding))
|
|
(? ((file-extension->content-type filename) =>
|
|
(lambda (ct) (format out "Content-type: ~A\r~%" ct)))))
|
|
(format out "Last-modified: ~A\r~%"
|
|
(time->http-date-string (file-info:mtime info)))
|
|
(format out "Content-length: ~D\r~%" (file-info:size info))
|
|
(write-string "\r\n" out))
|
|
(copy-inport->outport in out))))))
|
|
|
|
|
|
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
|
|
;;; If the assembled filename contains a .. subdirectory, return #f,
|
|
;;; otw return the filename.
|
|
|
|
(define dotdot-check
|
|
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
|
|
(lambda (root path-list)
|
|
(let ((fname (if (null? path-list) root ; Bogus hack.
|
|
(string-append (file-name-as-directory root)
|
|
(join-strings path-list "/")))))
|
|
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
|
|
fname)))))
|
|
|
|
|
|
(define (file-extension->content-type fname)
|
|
(switch string-ci=? (file-name-extension fname)
|
|
((".html") "text/html")
|
|
((".txt") "text/plain")
|
|
((".gif") "image/gif")
|
|
((".png") "image/png")
|
|
((".jpg" ".jpeg") "image/jpeg")
|
|
((".tiff" ".tif") "image/tif")
|
|
((".rtf") "text/rtf")
|
|
((".mpeg" ".mpg") "video/mpeg")
|
|
((".au" ".snd") "audio/basic")
|
|
((".wav") "audio/x-wav")
|
|
((".dvi") "application/x-dvi")
|
|
((".tex" ".latex") "application/latex")
|
|
((".zip") "application/zip")
|
|
((".tar") "application/tar")
|
|
((".ps") "application/postscript")
|
|
((".pdf") "application/pdf")
|
|
(else "application/octet-stream")))
|
|
|
|
(define (file-extension->content-encoding fname)
|
|
(cond
|
|
((switch string-ci=? (file-name-extension fname)
|
|
((".Z") "x-compress")
|
|
((".gz") "x-gzip")
|
|
(else #f))
|
|
=> (lambda (encoding)
|
|
(values (file-name-sans-extension fname) encoding)))
|
|
(else (values fname #f))))
|
|
|
|
;;; Timeout on network writes?
|
|
|
|
(define (copy-inport->outport in out)
|
|
(let ((buf (make-string server/buffer-size)))
|
|
(let loop ()
|
|
(? ((read-string! buf in) => (lambda (nchars)
|
|
(write-string buf out 0 nchars)
|
|
(loop))))))
|
|
(force-output out))
|