[hunchentoot-devel] dispatch-table request

[Otto Diesenbacher]

Cyrus Harmon <ch-tbnl at bobobeach.com> writes:

> First of all, thanks for hunchentoot! I'm still getting used to it,
> but it seems great so far. But I do have a request. Would it be
> possible (and advisable) to extend the dispatch table to provide some
> metadata for each dispatcher? this could even be done in a backward

first, i am rather new to lisp, but perhaps my additions / changes to
the hunchentoot:*dispatch-table* are useful or interesting for someone.

(Please excuse the mixture of tbnl / hunchentoot naming in the
following code)

some stuff could propably be done better, much better :) feel free to
criticise :)

and finally: thanks to Edi and all the other people in the
lisp-community, that produces so wonderful things like hunchentoot! :)


;; I wanted a *dispatch-table*, so that I can add, remove or update the
;; dispatch-functions while a hunchentoot-server is running.
;;
;; f.e. my dispatch-table looks like:

;; CL-USER> hunchentoot:*dispatch-table*
;; (("/web/log" #<CLOSURE # {B4A5515}>)
;;  ("/web/error.html" #<CLOSURE # {B4792ED}>)
;;  ("/web/index.html" #<CLOSURE # {B4776E5}>)
;;  ("/web/style.css" #<CLOSURE # {B4755E5}>)
;;  ("default" #<FUNCTION HUNCHENTOOT:DEFAULT-DISPATCHER>))

;; i redefined the method. Both types of entries should work (plain
;; function, as in the "original" hunchentoot and my "new" entries
;; '("somestring" #function)). The "somestring" is later used to identify
;; the dispatch function. 

;;; Redefined original hunchentoot:dispatch-request
(defmethod dispatch-request (dispatch-table)
  "Dispatches *REQUEST* based upon rules in the DISPATCH-TABLE.
This method provides the default tbnl/hunchentoot behavior."
  (loop for dispatcher in dispatch-table
     for action = (if (typep dispatcher 'list)
		      (funcall (cadr dispatcher) *request*)
		      (funcall dispatcher *request*))
     when action
     return (funcall action)
     finally (setf (return-code *reply*)
		   +http-not-found+)))

;; and use the following functions to work with the "new" dispatch-table

(defun safe-assoc-string (item list)
  (loop for i in list
     when (if (and (listp i)
		   (stringp (car i)))
	      (string= (car i) item))
	      return i))

(defun add-dispatcher (path function)
  "adds dispatcher to tbnl:*dispatch-table*"
  (if (safe-assoc-string path hunchentoot:*dispatch-table*)
      ;;there is already a dispatcher with that identifier
      (setf (cadr (safe-assoc-string path tbnl:*dispatch-table*)) function)
      ;;create a new entry
      (push (list path function) tbnl:*dispatch-table*)))

(defun add-dispatcher-prefix (path function)
  "convient way to construct a dispatcher with prefix."
in a lambda to call the statistic writer before."
  (add-dispatcher path (funcall #'tbnl:create-prefix-dispatcher
				path
				#'(lambda ()
				  ;;  (write-statistic tbnl:*request*) ; my statistics function
				    (funcall function)))))

(defun remove-dispatcher (path)
  "remove a dispatch-entry by their path"
  (setf tbnl:*dispatch-table* (remove (assoc path tbnl:*dispatch-table* :test #'string=)
				      tbnl:*dispatch-table*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; additionally i made the following macros, so that i simply have to evaluate f.e.
;; 
;; (defweb "/my/page.html"
;;   (bla
;;     (bla ....)))
;;
;; or for webpages that need parameters
;;
;; (defweb* "/my/page.html" (firstparameter secondparameter)
;;   (bla
;;     (setf firstparameter 'new-value)
;;     (...)))
;;
;; and the function that listen at the path "/my/page.html" is created or updated
;;
;;
;; the macros (and some condition-stuff i use):


(define-condition web-error (error)
  ((message :initarg :message :reader message)))

(defmacro error-page (fehler)
  `(tbnl:redirect (format nil "/web/error.html?fehler=~A" (tbnl:url-encode ,fehler))))

(defmacro defweb (path &body body)
  "constructs a defun + entry into tbnl:*dispatch-table*"
  (let ((funcn (read-from-string path)))
    `(progn
       (defun ,funcn ()
	 (handler-case (progn
			 , at body)
	   (web-error (fehler)
	     (web:error-page (message fehler)))))
       (compile (quote ,funcn))
       (add-dispatcher-prefix ,path (function ,funcn)))))

(defmacro defweb* (path parameters &body body)
  "constructs a defun + entry into tbnl:*dispatch-table* and prepares local variables
coresponding to the parameters.

f.e. (web:defweb* \"/web/test\" (a)
         (format nil \"~A\" a))

it is also possible to prepare a conversion of the variable. Put the definition in extra
brackets.

f.e. (web:defweb* \"/web/test\" ((a #'parse-integer))
         (format nil \"type of a ~A\" (type-of a)))
"
  (let ((funcn (read-from-string (string path))))
    `(progn
       (defun ,funcn ,(if parameters
			  (append
			   '(&aux )
			   (loop for i in parameters collect
				(if (listp i)
				    `(,(car i)
				       (funcall ,(cadr i)
						(tbnl:parameter ,(string-downcase (string (car i))))))
				    `(,i (tbnl:parameter ,(string-downcase (string i))))))))
	 (handler-case (progn
			 , at body)
	   (web-error (fehler)
	     (web:error-page (message fehler)))))
       (compile (quote ,funcn))
       (add-dispatcher-prefix ,path (function ,funcn))
       ',funcn)))

best regards

     okflo

-- 
Otto Diesenbacher
diesenbacher at gmail.com                      
Salzburg, Österreich