sunet/httpd-handlers.scm

;;; 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)
      
      (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 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)
  (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)
  
  (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)
      (let ((request-method (request:method req)))
	(cond
	 ((or (string=? request-method "GET")
	      (string=? request-method "HEAD"))
	  
	  (if (not (eq? 'directory 
			(file-info:type (stat-carefully fname req))))
	      (http-error http-reply/forbidden req))
	  
	  (if (not (v0.9-request? req))
	      (begin
		(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 /"
					(string-join (list 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 ]"))
		 (if (not (null? file-path))
		     (begin
		       (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)))
	  (if (not (v0.9-request? req))
	      (begin
		(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))
			 (cond ((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)
				      (string-join (list path-list "/"))))))
	(and (not (regexp-exec dotdot-re fname))	; Check for .. subdir.
	     fname)))))


(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))))
   
;;; Timeout on network writes?

(define (copy-inport->outport in out)
  (let ((buf (make-string server/buffer-size)))
    (let loop ()
      (cond ((read-string! buf in) => (lambda (nchars)
					(write-string buf out 0 nchars)
					(loop))))))
  (force-output out))