sunet/scheme/httpd/handlers.scm

;; Request-handlers for scheme web server

;; general request-handler-combinator:
;; predicate: path x request --> boolean
;; if #t, handler is called
;; if #f, default-handler is called
(define (make-request-handler predicate handler default-handler)
  (lambda (path req)
    (if (predicate path req)
	(handler path req)
	(default-handler path req))))

;; same as make-request-handler except that the predicate is only
;; called with the path:
;; predicate: path --> boolean
(define (make-path-handler predicate handler default-handler)
  (make-request-handler
   (lambda (path req) (predicate path)) handler default-handler))

;; selects handler according to host-field of http-request
(define (make-hostname-handler hostname handler default-handler)
    (make-request-handler 
     (lambda (path req)
       ;; we expect only one host-header-field
       (string=? hostname (string-trim (get-header (request:headers req) 'host))))
     handler default-handler))

;; selects handler according to path-prefix
;; if path-prefix matches, handler is called without the path-prefix
(define (make-path-prefix-handler path-prefix handler default-handler)
  (lambda (path req)
    (if (string=? path-prefix (car path))
	(handler (cdr path) req)
	(default-handler path req))))

(define server/buffer-size 8192)	; WTF


;;; (alist-path-dispatcher handler-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)
  (fold-right 
   (lambda (handler-pair default-handler)
     (make-path-prefix-handler
      (car handler-pair)
      (cdr handler-pair)
      default-handler))
   default-handler
   handler-alist))

;;; (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-predicate path)
;;; (tilde-home-dir-handler user-public-dir)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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-predicate path)
  (lambda (path)
    (and (pair? path)			; Is it a ~foo/...
	 (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)
  (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)))
      (serve-rooted-file-path subdir (cdr path) file-serve req))))


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