sunet/scheme/httpd/file-dir-handler.scm

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

;;; (tilde-home-dir-handler user-public-dir default-request-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-handler)
  (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)))
   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)
  (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-error-response (status-code 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-error-response (status-code 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 (status-code not-found) req))
    ((errno/acces)
     (http-error (status-code 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-error-response
		(status-code moved-perm) req
		(string-append (request-uri req) "/")
		(string-append (http-url->string (request-url req))
			       "/")))

	      (else (make-error-response (status-code forbidden) req)))))
	 
	 (else 
	  (make-error-response (status-code 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 ".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)
     ((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)
     ((or (string-ci=? ext ".mpeg")
	  (string-ci=? ext ".mpg")) 'movie)
     ((or (string-ci=? ext ".au")
	  (string-ci=? ext ".snd")
	  (string-ci=? ext ".mp3")
	  (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-error-response (status-code forbidden) req)
	  (make-response
	   (status-code ok)
	   #f
	   (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-error-response (status-code 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 (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)
  (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)
	(make-response (status-code ok)
		       #f
		       (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 ".htm")		"text/html")
     ((string-ci=? ext ".html")		"text/html")
     ((string-ci=? ext ".txt")       	"text/plain")
     ((string-ci=? ext ".doc")       	"application/msword")
     ((string-ci=? ext ".gif")		"image/gif")
     ((string-ci=? ext ".png")		"image/png")
     ((string-ci=? ext ".bmp")		"image/bmp")
     ((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 ".hqx")		"application/mac-binhex40")
     ((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))))