From 2c9b931100b55ccef84f296413ba15f5c6e094d2 Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 22 Aug 2002 15:32:03 +0000 Subject: [PATCH] added handler combinators and adapted current basic handlers --- scheme/httpd/handlers.scm | 117 +++++++++++++++++++------------------- scheme/packages.scm | 21 ++++--- 2 files changed, 72 insertions(+), 66 deletions(-) diff --git a/scheme/httpd/handlers.scm b/scheme/httpd/handlers.scm index 8178242..8eb26e6 100644 --- a/scheme/httpd/handlers.scm +++ b/scheme/httpd/handlers.scm @@ -1,47 +1,42 @@ -;;; http server in the Scheme Shell -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. +;; 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. diff --git a/scheme/packages.scm b/scheme/packages.scm index c9bddaf..64e6cb7 100644 --- a/scheme/packages.scm +++ b/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)))