Doing more with Hunchentoot (Common Lisp webserver)

In a previous article, I gave a very simple introduction to using Hunchentoot, Edi Weitz's Common Lisp webserver. As someone noted in the Reddit comments, it was not really a wonderful article, and didn't tell you much that you couldn't get easily from the documentation.

Now, before I start, I should note that the sort of thing I'm going to be doing is very much personal taste, and may not suit your development style at all. I'm not even sure that it suits mine that well, but it's just a little introduction to give you a feel for the sorts of things that you can do easily in Lisp, and how they relate to writing a web application.

I'm going to be writing a simple, pointless webapp with user login. For this, I will put together a very simple framework. Frameworks are, of course, very popular in the web development world, and tend, by and large, to be vast, constraining things suited for writing a particular type of application. I hope to show here that it is easy, in Lisp, to put together a simple framework to suit your application's needs as you write it.

I'm going to be using macros here. Macros in Common Lisp are quite sophisticated creatures; they are effectively functions which produce code at runtime. I'll also be using a couple of nice Hunchentoot features that I didn't mention the first time around; sessions, which let you store data associated with a web client, and hunchentoot-mp, a set of cross-platform functions for dealing with multi-processing which comes with Hunchentoot. I'll also be using cl-who, a HTML generation library.

Hunchentoot sessions work by giving the client a session-identifying cookie, and storing the session data itself in memory on the webserver. This approach has its limitations; in particular, it is problematic if you are using more than one webserver; however, it is fine for a simple application like this. The multi-processing functions are handy because the Hunchentoot server runs as a series of Lisp processes (threads) in a single Lisp environment; if we need to store non-user-specific data in memory, we have to prevent two users attempting to write to it at the same time.

The web application consists of an authentication-protected site where users can perform a variety of actions depending on their assigned roles. Actions will set statuses, much like on Facebook; they'll be stored in a mutex-locked list. Users will be able to view just their own statuses, or everyone's. Each user can have more than one role, and each role can require one or more roles. As it's just a little example, there'll be no persistence; user accounts will be defined in a list, and statuses will be stored in memory. In a real application of this type, of course, you'd probably use a database or other persistent store.

It would be convenient to have details on the current user from the session available in each page handler. One way to handle this would be to just do a (let ((user-details ...)))enclosing the handler contents, but the way I'm going to do it is writing a macro with syntax (with-user-details (user-details) ...). There's not much obvious gain from this in this instance, but it looks a bit nicer, and it would be convenient if more work ever had to be done in that session data retrieval bit. For instance, you might want to add a line to a log every time a logged-in user viewed a page, or do something with the result of the page generation function.

I'd also like to be able to have certain parts of the page only displayed for registered users with the correct roles. For this, I'll use another little macro. (display-with-roles user-details list-of-roles ...)

I'd also like to use a basic page template. Again, this can be nicely implemented in a macro, and then the display code for a given page wrapped in (with-template ...).

Finally, it looks like there's a fair bit of functionality every page is going to require. Page handlers are functions, but there's no reason that we have to define them using plain old defun. Instead, we have yet another macro, defpage. This macro wraps the code provided to it in the with-user-details macro, and the with-template macro. It also puts in code to check that the user is allowed to view the page at all, and adds the page handler to hunchentoot's dispatch table. (defpage page-name url roles-required ..).

I'll also have a (defevent page-name url roles-required text). This will just create a page which performs an event.

So, without further ado, here's the code. It's not perfect, and for this small application it's possibly a bit long, but it does make it easier to write apps of this sort. You can try it outhere.

(defpackage :demoserv2
  (:use :hunchentoot
        :cl-who
        :cl)
  (:export
   :start-server))

(in-package :demoserv2)

(setq *dispatch-table* (list (create-regex-dispatcher "^/login$" 'login)))
                           

(defparameter *users* '(("mags" "icecream" (:scary-hair :evil))
                        ("annie" "mrpugwash" (:ann-widdicombe))
                        ("tony" "gwbush" (:evil :boring :scary-wife))
                        ("john" "grey" (:boring))))
                      

(defvar *our-mutex* (hunchentoot-mp:make-lock "our-lock"))
(defvar *events* '())

; Add event to log
(defun add-event (user text)
  (hunchentoot-mp:with-lock (*our-mutex*)
    (push `(,user ,text) *events*)))

; Does this user have access to these roles?
(defun has-access (user-details required-roles)
  (reduce #'(lambda (a b) (and a b))
               (mapcar #'(lambda (role) (find role (second user-details)))
                                 required-roles)))

; Get user details from session
(defmacro with-user-details (user-details &body body)
  `(let ((,user-details (session-value :user)))
     ,@body))

; Display body if the user is allowed access it
(defmacro display-with-roles (user-details required-roles &body body)
  `(if (and user-details (has-access ,user-details ,required-roles))
       ,@body))

; Template
(defmacro with-template (title user-details &body body)
  `(with-html-output-to-string (*standard-output*)
    (:html
     (:head (:title (fmt "Hunchentoot demo - ~a" ,title)))
     (:body (:h1 "Hunchentoot Demo")
            (:div (:a :href "/" "Menu") " - "
                  (:a :href "/events" "Events")
                  (if user-details
                      (htm " - " (:a :href "/logout" "Logout"))))
            ,@body))))

; Defines a normal page with basic infrastructure
(defmacro defpage (name url required-roles user-details &body body)
  `(progn
     (defun ,name ()
       (with-user-details ,user-details
         (if (or (not ,required-roles)
                 (has-access ,user-details ,required-roles))
             (progn ,@body)
             "You're not allowed view this page")))
     (push (create-regex-dispatcher ,(format nil "^/~a$" url) ',name)
           *dispatch-table*)))

; Defines an event page
(defmacro defevent (name url required-roles text)
  `(defpage ,name ,url ,required-roles user-details
     (add-event (first user-details) ,text)
     (with-template ,text user-details
       (htm (:h3 "Event Registered") (str ,text)))))

; Index
(defpage index-page "" nil user-details
  (with-template "Index" user-details
    (:div
     (if (not user-details)
         (htm (:form :action "/login" :method "post"
                     "Username:" (:input :type "text" :name "username")
                     "Password:" (:input :type "password" :name "password")
                     (:input :type "submit" :value "submit"))))
     (htm (:ul
           (display-with-roles user-details '(:scary-hair)
                       (htm (:li (:a :href "/impose-poll-tax" "Impose Poll Tax"))))
           (display-with-roles user-details '(:evil)
                       (htm (:li (:a :href "/have-a-war" "Have a Nice War"))))
           (display-with-roles user-details '(:scary-hair :evil)
                       (htm (:li (:a :href "/ice-cream" "Invent Soft Ice-cream"))))
           (display-with-roles user-details '(:boring)
                       (htm (:li (:a :href "/eat-peas" "Eat Peas"))))
           (display-with-roles user-details '(:scary-wife)
                       (htm (:li (:a :href "/flats" "Have Flat Investment Scandal"))))
           (display-with-roles user-details '(:ann-widdicombe)
                       (htm (:li (:a :href "/celeb-fat" "Go on Celebrity Fat Farm")))))))))

; Events
(defevent impose-poll-tax "impose-poll-tax" '(:scary-hair) "Poll tax imposed!")
(defevent celeb-fat "celeb-fat" '(:ann-widdicombe) "Went to Celebrity Fat Farm!")
(defevent have-a-war "have-a-war" '(:evil) "Had a nice war. I do like those.")
(defevent ice-cream "ice-cream" '(:evil :scary-hair) "Invented soft ice-cream.")
(defevent eat-peas "eat-peas" '(:boring) "Peas are nice, dear!")
(defevent flats "flats" '(:scary-wife) "Buy flat through fraudster.")

(defpage logout "logout" nil user-details
  (delete-session-value :user)
  (redirect "/"))

; Events listing
(defpage events "events" nil user-details
  (let* ((user (parameter "user"))
         (our-events (if user
                         (remove-if-not #'(lambda (a) (equal user a))
                                        (hunchentoot-mp:with-lock (*our-mutex*)
                                          *events*)
                                        :key #'first)
                         (hunchentoot-mp:with-lock (*our-mutex*)
                           *events*))))
    (with-template "Events" user-details
        (htm (:h3 "Events")
             (:ul
              (dolist (i our-events)
               (htm (:li (:a :href (format nil "/events?user=~a" (first i)) (str (first i))) " - "
                             (str (second i))))))))))

(defun login ()
  (let ((username (parameter "username"))
        (password (parameter "password")))
    (let ((user-details (find username *users* :test #'equal :key #'first)))
          (if user-details
              (cond ((equal (second user-details) password)
                     (start-session)
                     (setf (session-value :user) (list (first user-details)
                                                      (third user-details)))
                     (redirect "/"))
                    (t "Bad password"))
              "Non-existent user"))))