added handler combinators and adapted current basic handlers

scheme/httpd/handlers.scm

@@ -1,47 +1,42 @@
-;;; http server in the Scheme Shell	-*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
+;; Request-handlers for scheme web server
 
-;;; 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
+;; 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))))
 
-;;; 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.
+;; 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 hander-alist default-handler) -> handler
+;;; (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
@@ -54,11 +49,14 @@
 ;;; 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)))))
-
+  (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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -85,28 +83,29 @@
 	(http-error http-reply/bad-request req
 		    "Path contains no home directory."))))
 
-;;; (tilde-home-dir-handler user-public-dir default)
+;;; (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 user-public-dir default-ph)
-  (lambda (path req)
-    (if (and (pair? path)			; Is it a ~foo/...
+(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) #\~))))
+		(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))
-
-	(default-ph path req))))		; No.
+      (serve-rooted-file-path subdir (cdr path) file-serve req))))
 
 
 ;;; Make a handler that serves files relative to a particular root
@@ -120,7 +119,7 @@
 ;;; 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
+;;; 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.

scheme/packages.scm

@@ -350,9 +350,14 @@
 	  title-html))
 
 (define-interface httpd-basic-handlers-interface
-  (export alist-path-dispatcher
+  (export make-request-handler
+	  make-path-handler
+	  make-hostname-handler
+	  make-path-prefix-handler
+	  alist-path-dispatcher
 	  home-dir-handler
 	  tilde-home-dir-handler
+	  tilde-home-dir-handler-predicate
 	  rooted-file-handler
 	  rooted-file-or-directory-handler
 	  null-path-handler
@@ -723,6 +728,8 @@
 	url				; HTTP-URL record type
 	handle-fatal-error		; WITH-FATAL-ERROR-HANDLER
 	string-lib			; STRING-JOIN
+	list-lib			; FOLD-RIGHT
+	rfc822				; GET-HEADER
 	scheme)
   (files (httpd handlers)))