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)
+(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)
-    (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.
+    (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
@@ -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
@@ -712,17 +717,19 @@
   (files (httpd text-generation)))
 
 (define-structure httpd-basic-handlers httpd-basic-handlers-interface
-  (open scsh		; syscalls
-	formats		; FORMAT
+  (open scsh				; syscalls
+	formats				; FORMAT
 	httpd-request			; REQUEST record type, v0.9-request
 	httpd-reply-codes		; reply codes
 	httpd-text-generation		; begin-http-header
 	httpd-error			; HTTP-ERROR
 	htmlout
-	conditions	; CONDITION-STUFF
-	url		; HTTP-URL record type
-	handle-fatal-error  ; WITH-FATAL-ERROR-HANDLER
-	string-lib      ; STRING-JOIN
+	conditions			; CONDITION-STUFF
+	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)))