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

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