The blog

Obviously I'm no longer using the software I wrote here, and this code is outdated now. Hunchentoot has changed quite a bit since I wrote this. You've been warned.

I want to make a blog framework. Because, if there is one thing the world needs these days, it's another blog framework. I also couldn't find much example code around for TBNL, a web framework by Edi Weitz which I've been looking at looking at. (I didn't search that hard for examples, and quite a bit of the code below is from examples I found after starting to write this.) Anyway, I figured I'll just make some example code myself and keep it around in case I need it later.

Bill Clementson has written about getting TBNL up and running with apache and mod_lisp. In this example I'm going to use hunchentoot, a pure lisp web server by (again) Edi Weitz.

After reading the the third chapter of Practical common lisp by Peter Seibel we choose to use simple lists to store data about the blog, because ripping off code is way easier than writing our own. We'll keep individual entries in separate files so writing and editing them can be done with whatever tools we want to use.

Let's get started:

(defparameter *blog-db-item-dir* "/home/asbjxrn/blog/items/")
(defparameter *blog-db-file* "/home/asbjxrn/blog/blog-db")
(defparameter *blog-db* ())

(defun create-blog (&key id title description author)
  "Create a new blog by pushing a list containg a blog description onto the blog database.
Return the updated blog-database."
  (let ((new-blog (list
                   :id id
                   :title title
                   :description description
                   :author author
                   :items ())))
    (push new-blog *blog-db*)
    new-blog))

As you can see, I've made room for growth. *blog-db* is a list of blogs. This means we need some functions to find/list/delete the blogs. The print functions I only used for debugging/testing of the blog framework.

(defparameter *blog-hosts-prefix* "http://www.jalat.com")
(defparameter *blog-script-name-prefix* "/blogs/")

(defun print-blog-headers (blog)
  "Prints out everything but the items of a blog."
  (format t "Name: ~a~%Title: ~a~%Description: ~a~%Homepage: ~a~%Author: ~a~%~%"
          (getf blog :id)
          (getf blog :title)
          (getf blog :description)
          (getf blog :author)))

(defun print-blogs ()
  "Prints out the name, title, homepage, descripton and author of all the registered blogs"
  (loop for blog in *blog-db*
        do (print-blog-headers blog)))

(defun homepage (blog)
  "Generates the homepage uri for the blog"
  (format nil "~a~a~a" *blog-hosts-prefix* *blog-script-name-prefix*
          (getf blog :id)))
                 
(defun get-blog (name)
  "Returns the blog identified by \"name\""
  (when (stringp name)
    (find-if #'(lambda (x) (string= name (getf x :id)))
             *blog-db*)))

(defun delete-blog (name)
  "Deletes the blog identified by \"name\". Destructive on *blog-db*"
  (when (stringp name)
    (setf *blog-db*
          (remove-if #'(lambda (x) (string= name (getf x :id)))
                     *blog-db*))))

So far so good, time to add some functions for handling the items in each blog. since values passed to us through a get or post are strings, I parse the id arguments if they are strings:

(defun max-blog-id (blog)
  "Find the highest id of any item in a blog."
  (if (getf blog :items)
    (apply #'max (loop for entry in (getf blog :items)
                       collect (getf entry :id)))
    0))

(defun add-blog-item (blog &key title file description)
  "Add a new item in a blog."
  (push
   (list :title title
         :file file
         :description description
         :pub-time (get-universal-time)
         :id (+ 1 (max-blog-id blog)))
   (getf blog :items)))

(defun delete-blog-item (blog id)
  "Deletes a item in a blog. Destructive on the blog"
  (if (stringp id)
    (setf id (parse-integer id :junk-allowed t)))
  (setf (getf blog :items)
        (remove-if #'(lambda (x) (eql id (getf x :id)))
                   (getf blog :items))))

(defun get-blog-item (blog id)
  "Find blog item with id id."
  (if (stringp id)
    (setf id (parse-integer id :junk-allowed t)))
  (find-if #'(lambda (x) (eql id (getf x :id)))
           (getf blog :items)))

(defun get-last-blog-item (blog)
  "Return the last item for a blog"
  (get-blog-item blog (max-blog-id blog)))

(defun list-blog-items (blog)
  "Print a list of items in a blog."
  (format t "~{~{~a:~t~a~%~}~%~}" (getf blog :items)))

A couple of functions to store and load our data from disk:

(defun save-blog-db ()
  "Simply write out the blog structure to the db file."
  (with-open-file (out *blog-db-file*
                       :direction :output
                       :if-exists :supersede)
    (with-standard-io-syntax
      (print *blog-db* out))))

(defun load-blog-db ()
  "Simple read in the whole db in one operation."
  (with-open-file (in *blog-db-file*)
    (with-standard-io-syntax
      (setf *blog-db* (read in)))))

And some functions to read the blog entries from disk. To improve performance one might want to keep everything in memory, but I don't think that is going to be an issue. Besides, it's convenient to be able to just edit the files themselvesm, and have the blog update automatically.

(defun slurp-file (filename)
  "Dump the contents of a file into a string."
  (with-open-file (stream filename)
    (let ((seq (make-string (file-length stream))))
      (read-sequence seq stream)
      seq)))

(defun get-blog-file (blog id)
  "Reads the file of a blog item and returns it as a string."
  (let* ((item (get-blog-item blog id))
         (filename (concatenate 'string *blog-db-item-dir* (getf item :file))))
    (slurp-file filename)))

I think I'm done with the backend. Time to start with TBNL. First some convenience functions to start and stop the server. In the start function I also set up my dispatch-table:

• /blogs/<foo> is handled by the function blog-page
• /admin is handled by the function manage-blogs
• A folder dispatcher serves all files in my static-files directory
• And I have a separate static file dispatcher that handles "/favicon.ico", generously stolen from planet.lisp.org.

Btw. These functions are Hunchentoot specific, use start-tbnl if you use mod_lisp, araneida or something else.

(defparameter *blog-script-name-prefix* "/blogs/")
(defparameter *blog-admin-uri* "/admin")
(defparameter *blog-static-uri* "/static-files/")
(defparameter *blog-static-dir* "/home/asbjxrn/blog/static-files/")
(defparameter *blog-server* nil)
(defparameter *log-file* "/home/asbjxrn/blog/log")

(defun start-blog (&key port)
  "starts up the server, and initializes our dispatch-table"
  (setf (log-file) (make-pathname :defaults *log-file*))
  (load-blog-db)
  (setq *blog-server*
        (tbnl:start-server :port port)
        *dispatch-table*
        (list (create-prefix-dispatcher *blog-script-name-prefix* 'blog-page)
              (create-prefix-dispatcher *blog-admin-uri* 'manage-blogs)              
              (create-folder-dispatcher-and-handler *blog-static-uri*
                                                    (make-pathname :defaults *blog-static-dir*))
              (create-static-file-dispatcher-and-handler "/favicon.ico"
                                                         (merge-pathnames
                                                          (make-pathname :defaults *blog-static-dir*)
                                                          "favicon.ico"))
              (create-prefix-dispatcher "/index.html" 'front-page)                            
              (create-prefix-dispatcher "/the-blog.html" 'manage-blogs)              
              'default-dispatcher)))

(defun stop-blog ()
  (tbnl:stop-server *blog-server*))

All blogs are handled by the same function which will use request-uri to get hold of the name of the blog the user wants to read. So I need a function that gets hold of the name by removing the /blogs/ part of the uri.
At the same time, I'll make a function that prints out a timestamp in a readable way. (Totally ignoring things like timezones etc.)

(defun remove-prefix (uri prefix)
  "Returns the prefix from an uri in search of a blog name. 
Big assumtion: Blog names consists only of latin characters."
  (let ((scanstring (concatenate 'string prefix "([A-Za-z]+)")))
    (multiple-value-bind (dummy matchvector) (cl-ppcre:scan-to-strings scanstring uri)
      (declare (ignore dummy))
      (if matchvector
        (svref matchvector 0)
        ""))))

(defun timestring (timestamp)
  "Takes a timestamp and returns a string formatted with year-month-day hour:minutes"
  (multiple-value-bind (sec min hour day mnt year weekday dst tz)
      (decode-universal-time timestamp)
    (declare (ignore sec weekday dst tz))
    (format nil "~d-~d-~d ~2,'0d:~2,'0d" year mnt day hour min)))

HTML coming up. At long last some HTML generation. I'm going to use the CL-WHO library written by Edi Weitz to generate the HTML, but you can use whatever you want as long as your handler functions returns strings containing HTML. One nice thing about this approac is that you can just call the functions from the REPL and see if you get the HTML you expect. Use :indent t to make it easier to read.

The first function is a function I'll use to make a navigation bar. It takes a list of items, and generates a list of anchor tags, where the title of the item is used as the text of the link and the id of the item is used to create a uri like "?id=5". So these uris will only point back to the same page, but I'll use the parameter to decide what to display.

(defun navigate-items (items)
  "Returns html code four our navigation sidebar."
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:ul
     (loop for item in items
           do (htm
               (:li
                (:a :href (format nil "?id=~a" (getf item :id))
                 (fmt "~a" (getf item :title)))
                (:br)
                (when (getf item :pub-time)
                  (htm (fmt "~a" (timestring (getf item :pub-time)))
                       (:br)))))))))

Finally the function that displays the blog item.
First I use script-name and remove-prefix to get the name of the blog, returning a 404 if the blog doesn't exist.
Then I use (get-parameter "id") to get the ?id=.. part of the uri if it exists. If it doesn't exist or no item with the specified id exist, I just show the latest item for this blog.

The page is split up in three parts, a header, the content, and a navigation bar.

(defparameter *blog-css-file* "/static-files/stylesheet.css")

(defun blog-page ()
  "Finally, the function that writes the html for our blog output."
  (let ((blog (get-blog (remove-prefix (script-name) *blog-script-name-prefix*))))
    (unless blog
      (setf (return-code *reply*)
            +http-not-found+)
      (return-from blog-page))
    (let* ((item-id (or (and (get-parameter "id")
                             (parse-integer (get-parameter "id")))
                        (max-blog-id blog)))
           (item    (get-blog-item blog item-id)))
      (unless item
        (redirect (format nil "~a?id=~a" (script-name) (max-blog-id blog)))
        (return-from blog-page))
      (with-html-output-to-string (*standard-output* nil :prologue t :indent t)
        (:html
         (:head
          (:title (fmt (concatenate 'string (getf blog :title) " - " (getf item :title))))
          (:link :href *blog-css-file* :rel "stylesheet" :type "text/css"))
         (:body
          (:div :id "Header"
           (:h1 (:a :href (getf blog :homepage)
                 (fmt "~a" (getf blog :title)))))
          (:div :id "Content"
           (:h3 (fmt "~a" (getf item :title)))
           (:p (fmt "~a" (get-blog-file blog (getf item :id)))))
          (:div :id "Menu"
           (:h4 "Blogged:")
           (fmt "~a" (navigate-items (getf blog :items))))))))))

And that's it. Get hold of some css, stuff it in /static-files/ and you should have a working website where people can go to read your latest musings. Of course, updating is a bit inconvenient as you have to execute commands create-blog/add-blog-item/etc. at the REPL. A simple form where one could maintain the data would me a lot more convenient...

It could look something like this:

(defun blog-form (blog)
  "A form with blog data."
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:h3 (:a :href (homepage blog)
          (fmt "~a" (or (getf blog :title) ""))))
    (:h5 (fmt "~a" (or (getf blog :description) "")))
    (:form :method :post 
     (:table 
      (:tr
       (:td "Title: ")
       (:td
        (:input :type :text
         :name "new-blog-title"
         :value (or (getf blog :title) ""))))
      (:tr
       (:td "Description: ")
       (:td
        (:input :type :text
         :name "new-blog-description"
         :value (or (getf blog :description) ""))))
      (:tr
       (:td "Homepage: ")
       (:td (fmt "~a~a" *blog-hosts-prefix* *blog-script-name-prefix*)
        (:input :type :text
         :name "new-blog-id"
         :value (or (getf blog :id) ""))))
      (:tr
       (:td "Author: ")
       (:td
        (:input :type :text
         :name "new-blog-author"
         :value (or (getf blog :author) ""))))
      (:tr
       (:td (:input :type :submit :name "delete-blog" :value "Delete blog"))
       (:td (:input :type :submit :name "update-blog" :value "Update blog")))))))

Not particulary pretty, but this is not for public consumption, so I don't care. To apply the changes we make in the form, I'll call this function:

(defun update-blog (blog)
  "parses the post parameters and updates the blog accordingly"
  (let ((post-parameter-p)
        (new-blog (or blog ())))
    (when (post-parameter "new-blog-title")
      (setf (getf new-blog :title) (post-parameter "new-blog-title"))
      (setq post-parameter-p t))
    (when (post-parameter "new-blog-description")
      (setf (getf new-blog :description) (post-parameter "new-blog-description"))
      (setq post-parameter-p t))
    (when (post-parameter "new-blog-id")
      (setf (getf new-blog :id) (post-parameter "new-blog-id"))
      (setq post-parameter-p t))
    (when (post-parameter "new-blog-author")
      (setf (getf new-blog :author) (post-parameter "new-blog-author"))
      (setq post-parameter-p t))
    (when post-parameter-p
      (unless blog
        (setf blog (apply 'create-blog new-blog)))
      (save-blog-db)))
  blog)

And similar functions for items within the blog, and a function that loops through the items in a blog and makes a form for each one:

(defun item-form (item)
  "A simple one-line form for a blog item"
  (with-html-output-to-string (*standard-output* nil)
    (:form :method :post 
    (:input :type :hidden :name "item-id" :value (getf item :id))
     (:tr
      (:td
       (:input :type :text
        :name "new-item-title"
        :value (or (getf item :title) "")))
      (:td
       (:input :type :text
        :name "new-item-description"
        :value (or (getf item :description) "")))
      (:td
       (:input :type :text
        :name "new-item-file"
        :value (or (getf item :file) "")))
      (:td (:input :type :submit :name "update-item" :value (if item "Update item" "Save item")))
      (when item
        (htm (:td (:input :type :submit :name "delete-item" :value "Delete item"))))))))

(defun update-item (blog)
  "Updates an item in a blog."
  (let ((post-parameter-p)
        (new-item (or (get-blog-item blog (post-parameter "item-id"))
                      ())))
    (when (post-parameter "new-item-title")
      (setf (getf new-item :title) (post-parameter "new-item-title"))
      (setq post-parameter-p t))
    (when (post-parameter "new-item-description")
      (setf (getf new-item :description) (post-parameter "new-item-description"))
      (setq post-parameter-p t))
    (when (post-parameter "new-item-file")
      (setf (getf new-item :file) (post-parameter "new-item-file"))
      (setq post-parameter-p t))
    (when post-parameter-p
      (unless (get-blog-item blog (getf new-item :id))
        (apply 'add-blog-item blog new-item)))
    (when post-parameter-p
      (save-blog-db))))


(defun blog-items-forms (blog)
  "makes a list of forms, one for each item in the blog"
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:table 
     (:tr
      (:th "Title") (:th "Description") (:th "File"))
     (fmt (item-form nil))
     (loop for item in (getf blog :items)
           do (fmt (item-form item))))))

The observant reader will have noticed that there are delete-buttons in the forms that are not handled by the above functions. I'm going to do that in this function that will be the central calling point from our admin-page:

(defun handle-update (blog)
  "apply changes to blog based on post parameters in the request"
  (cond
   ((post-parameter "delete-blog") (progn (delete-blog (getf blog :id))
                                     (redirect (format nil "~a?id=~a" (script-name)))))
   ((post-parameter "delete-item") (delete-blog-item blog (post-parameter "item-id")))
   ((post-parameter "update-blog") (update-blog blog))
   ((post-parameter "update-item") (update-item blog)))
  (redirect (format nil "~a" (request-uri))))

Finally the blog admin page. The only new thing here is that we put in some authorization control to prevent just anyone to connect and mess up our data.

(defun manage-blogs ()
  "Let the user manage his blogs"
  (multiple-value-bind (user password)
      (authorization)
    (cond ((or (string/= user "admin")
               (string/= password "admin"))    ; Noone will guess this.
           (require-authorization))
          (t
           (let ((blog (get-blog (get-parameter "id"))))
             (when (post-parameters)
               (handle-update blog))
             (with-html-output-to-string (*standard-output* nil :prologue t :indent t)
               (:html
                (:head
                 (:title (fmt (concatenate 'string
                                           (getf blog :title)
                                           " - admin - "
                                           (or (getf blog :title) ""))))
                 (:link :href *blog-css-file* :rel "stylesheet" :type "text/css"))
                (:body
                 (:div :id "Header"
                  (:h1 (fmt "Admin - ~a" (or (getf blog :title) ""))))
                 (:div :id "Content"
                  (fmt "~a" (blog-form blog))
                  (fmt "~a" (blog-items-forms blog)))
                 (:div :id "Menu"
                  (:a :href  (format nil "~a?id=" (script-name))
                   "New blog")
                  (:h4 "Blogs:")
                  (fmt "~a" (navigate-items *blog-db*)))))))))))

That is about it. There is also a dispatcher set up for index.html but you should be able to put something together yourself now and this write-up has become far longer than I was planning to make it. Other exercises for the reader are: generating rss feeds, file upload though the form, comments, etc.

As usual: Feedback welcome at asbjxrn@bjxrnstad.net