sizeof(uint32t)

A seemingly complete Qt API for CL

2009-03-19T18:51:00.000-04:00

Just came across this library called CommonQT.

It is more complete than the API I developed earlier. It is also using the KDE Smoke libraries which make it damn easy to create the API on the fly.

Very exciting.

Qt/Lisp: more progress

2008-07-31T11:06:00.000-04:00

I've replaced the unsightly (make-instance 'qstring :ch "Foo") with a reader macro: #q"Foo". Ideally we'd use cl:string and qstring interchangeably but right now its too much of a PITA to make that work.

I've also made it possible to use closures for slots (see example below.) Frickin sweet.

Anyway, I started getting into the Dock Widgets example but lost interest after seeing all the code. Here is the code so far. Not very concise yet but will get there. Once I get into make-it-less-ugly mode, I will probably copy what Paul did with EQL as he calls it now.

~~Also the :foreign-pointer thingy will go away when I get around to adding cffi type translations.~~

Simple CFFI - Qt4 integration attempt

2008-07-22T13:04:00.000-04:00

Update: Paul has sent me his code. He calls it "EQL" for ECL and Qt. Or something like that anyway! I have put it up here.

The author of the Simple CFFI - Qt4 integration attempt has contacted me to let me know that a modification of the above linked software is in commercial use. I have prodded him to release his modified version. He says he'll do it Real Soon Now (TM).

I don't know if he is reading this blog but maybe a little pressure will help. Just kidding!

What I like most about his method is the use of the introspection capabilities of Qt. Compared to the duct tape and glue I used, his is a lot more elegant. Currently, you cannot extend Qt in Lisp (via inheritance) but all the other goodies are still there. Indeed he tells me that for his application, he extended Qt from within C++ and used these extensions from his Lisp.

I look forward to the update and to using the library.

Qt/Lisp: looking for feedback

2008-07-18T13:22:00.000-04:00

Update: You can download the generated code from here.

The tubes were down this morning, so I managed to get up to tutorial 6 in my Qt/Lisp API. It covers about 95% of the API by design so most of the non-extension tutorials/examples should work.

Tutorial 1:

Tutorial 2

Tutorial 3

Tutorial 4

Tutorial 5

Tutorial 6

I would like to hear your complaints, suggestions, feedback if you have any.

Note that this API is a first draft and I thought it better to have something out there than wait until everything is perfect.

To start with, my current complaints:

(in-package :qt) -> Nothing is actually exported from the package yet :-)

~~(make-instance 'qstring ...) -> A really verbose way to pass a string! Should convert lisp strings to qstrings automagically.~~

Naming: instead of qpush-button, q:push-button

No way to extend Qt from within Lisp yet (tutorial 7 won't work)

~~No way to attach arbitrary functions as slots~~

Not Lispy enough.

I expect to address most of these at some point though the "Not Lispy enough" complaint is a bit subjective.

YUI and Parenscript

2008-05-29T01:18:00.000-04:00

Parenscript is a nice little mini-language that lets you compile Lisp to JavaScript. Sort of like Google does with GWT and the language to end all languages: Java.

Parenscript code looks like this:


(ps:ps
  (defun say-hi ()
    (alert "Hi!"))
  (say-hi))

The macro ps:ps compiles the Lisp code to a JS string which looks like this:


function sayHi() {
    alert('Hi!');
};
sayHi();

Notice the conversion from say-hi to sayHi. I love the Common Lisp naming conventions. They make so much sense and I miss them everywhere else. Obviously the writers of Parenscript agreed with me so they convert each symbol they see into a JS symbol which keeps things looking mostly neat.

The major conventions are (I don't know that there are more):

*foo* becomes FOO

foo-bar becomes fooBar

foo.*bar becomes foo.Bar

Anyhoo, YUI is a largish but nice JavaScript library that one can use for creating quite interactive web applications.

The problem is that YUI has names like YAHOO.util.Event.onDOMReady which is a handful to type even in JavaScript. If you try converting this symbol via ParenScript you will be in for a surprise (try it!) Anyway, there are a couple of ways to write this in ParenScript and keep the casing intact without losing your hair:

*yahoo*.util.*event.on-d-o-m-ready

|:YAHOO.util.:Event.:onDOMReady|

This works because the bars prevent the reader from downcasing or upcasing the symbol and ParenScript promises that it will leave symbols that begin with a colon alone.

Even so, this is still a PITA to type. What I do is I have a wrapper script that gets compiled once with short names for all of these. So for the above example, using Hunchentoot:


(defin-easy-handler (my-yui :uri "/ps/my-yui.ps") ()
  (ps:ps
    (defun yui-on-dom-ready (fn) 
      (|:YAHOO.util.:Event.:onDOMReady| fn))
    (defvar yui-some-other-funky-name |:YAHOO.util.:FunkyChickens|)))

Yay.

Lisp compiler for .NET

2008-05-14T03:36:00.000-04:00

I've always wanted to write a compiler for Lisp and .NET. And tonight I did both! Ok I lie. It only handles strings right now but my plan is to add some type inference soon and see how things go. This would not be any sort of faithful lisp implementation as it would be a bearable skin on .NET. To me, that would be worth the work.

Input:


(import "mscorlib")
(assembly "hello")

(defun print-it ()
  (print "Hello! How are you?")
  (print "I am fine!"))

(defun main ()
  (.d entrypoint)
  (print-it))

MSIL output:


.assembly extern mscorlib {}
.assembly hello {}
.method static public void PRINT_IT () cil managed
{
.maxstack 1
ldstr "Hello! How are you?"
call void [mscorlib]System.Console::WriteLine(class System.String)
ldstr "I am fine!"
call void [mscorlib]System.Console::WriteLine(class System.String)
ret
}
.method static public void MAIN () cil managed
{
.maxstack 1
.entrypoint
call void PRINT_IT
ret
}

Program output:


sohail@dev-ubuntu-wks:/tmp$ mono foo.exe 
Hello! How are you?
I am fine!

Now I can go to sleep!

Mandelbrot generator in Common Lisp

2008-04-24T00:56:00.000-04:00

A couple of months back I had a bad flu and couldn't really do much so of course I wrote a Mandelbrot generator. This took me between .5 hr to 1 hr so go easy on me. Just dug it up today b/c of a discussion I was having so thought I'd post it here. It uses cl-opengl.


(in-package #:cl-glut-examples)

(progn (setq glut::*argcp* (cffi:null-pointer) glut::*argv* (cffi:null-pointer)))(glut:init)

(defclass mandelbrot-window (glut:window)
  ((image :initform nil
          :accessor image)
   (width :initarg :width
          :accessor width)
   (height :initarg :height
           :accessor height)
   (need-recalc :initform t
                :accessor need-recalc)
   (real-extents :initarg :real-extents
                 :accessor real-extents)
   (imag-extents :initarg :imag-extents
                 :accessor imag-extents))
  (:default-initargs :pos-x 100 :pos-y 100
                     :mode '(:single :rgb) :title "mandelbrot.lisp"))

(defmethod glut:display-window :before ((w mandelbrot-window))
  ;; Select clearing color.
  (gl:clear-color 0 0 0 0)
  ;; Initialize viewing values.
  (gl:matrix-mode :projection)
  (gl:load-identity)
  (gl:ortho 0 1 0 1 -1 1))

(defmethod glut:display ((w mandelbrot-window))
  (gl:clear :color-buffer)
  (gl:raster-pos 0 0)
  (when (need-recalc w)
    (format t "Need to recalc...~%")
    (format t "Real: ~A Imag: ~A~%" (real-extents w) (imag-extents w))
    (setf (image w) (calculate-mandelbrot-image (width w) (height w) :real (real-extents w) :imag (imag-extents w) :max-iterations 256))
    (setf (need-recalc w) nil)
    (format t "Done...~%"))
  (gl:draw-pixels (image-width (image w)) (image-height (image w)) :rgb :unsigned-byte (image-1darray (image w)))
  (gl:flush))

(defun rb-mandelbrot (width height &key (max-iterations 1000) (real '(-1.5 1.5)) (imag '(-1.5 1.5)))
  (glut:display-window 
   (make-instance 'mandelbrot-window
                  :width width :height height
                  :real-extents real :imag-extents imag)))
;                  :image (calculate-mandelbrot-image width height :real real :imag imag :max-iterations max-iterations))))

(defun midpoint (lst)
  (/ (+ (first lst) (second lst))
     2))

(defmethod glut:keyboard ((w mandelbrot-window) key x y)
  (with-slots (real-extents imag-extents) w
    (let ((imag-delta (* 4 (/ (- (second imag-extents) (first imag-extents)) (height w))))
          (real-delta (* 4 (/ (- (second real-extents) (first real-extents)) (width w))))
          (imag-midpoint (midpoint imag-extents))
          (real-midpoint (midpoint real-extents)))
      (case key
        (#\a 
         (incf (first imag-extents) imag-delta)
         (incf (second imag-extents) imag-delta))
        (#\A
         (incf (first imag-extents) (* 10 imag-delta))
         (incf (second imag-extents) (* 10 imag-delta)))
        (#\d 
         (incf (first imag-extents) (- imag-delta))
         (incf (second imag-extents) (- imag-delta)))
        (#\D
         (incf (first imag-extents) (* 10 (- imag-delta)))
         (incf (second imag-extents) (* 10 (- imag-delta))))
        (#\w
         (incf (first real-extents) (- real-delta))
         (incf (second real-extents) (- real-delta)))
        (#\s 
         (incf (first real-extents) real-delta)
         (incf (second real-extents) real-delta))
        (#\S
         (let ((imag-midpoint-distance (- imag-midpoint (first imag-extents)))
               (real-midpoint-distance (- real-midpoint (first real-extents))))
           (setf (first imag-extents) (- (first imag-extents) imag-midpoint-distance))
           (setf (second imag-extents) (+ (second imag-extents) imag-midpoint-distance))
           (setf (first real-extents) (- (first real-extents) real-midpoint-distance))
           (setf (second real-extents) (+ (second real-extents) real-midpoint-distance))))
        (#\W
         (setf (first imag-extents) (midpoint (list (first imag-extents)
                                                    imag-midpoint)))
         (setf (second imag-extents) (midpoint (list imag-midpoint
                                                     (second imag-extents))))
         (setf (first real-extents) (midpoint (list (first real-extents)
                                                    real-midpoint)))
         (setf (second real-extents) (midpoint (list real-midpoint
                                                     (second real-extents))))))
      (case key
        ((#\w #\s #\a #\d #\W #\D #\A #\S)
         (setf (need-recalc w) t)
         (setf (real-extents w) real-extents)
         (setf (imag-extents w) imag-extents)))))
  (glut:post-redisplay))

(defun make-image (w h)
  (let* ((underlying-array (make-array (* w h 3) :element-type '(unsigned-byte 8)
                                       :initial-element 0))
         (displaced-array (make-array (list w h 3) :element-type '(unsigned-byte 8)
                                      :displaced-to underlying-array)))
        
  (list w h underlying-array displaced-array)))

(defun image-width (image)
  (first image))

(defun image-height (image)
  (second image))

(defun image-1darray (image)
  (third image))

(defun image-3darray (image)
  (fourth image))

(defun set-colour (image x y iterations-taken max-iterations)
  (let (depth)
    (if (= iterations-taken max-iterations)
        (setf depth 0)
        (progn
          (setf depth (truncate (* 255 (/ iterations-taken 1000))))))
    (let ((r (min 180 (* 20 depth)))
          (g (min 180 (* 5 depth)))
          (b (min 180 (* 1 depth)))
          (data (image-3darray image)))
      (setf (aref data x y 0) r)
      (setf (aref data x y 1) g)
      (setf (aref data x y 2) b))))

(defun within-radius (z)
  (let ((r (realpart z))
        (i (imagpart z)))
    (<= (+ (* r r) (* i i))
        4)))

(defun calculate-mandelbrot-image (width height &key (max-iterations 1000)
                                   (real '(-1.5 1.5))
                                   (imag '(-1.5 1.5)))
  (let* ((image (make-image width height))
         (low-real (first real))
         (high-real (second real))
         (low-imag (first imag))
         (high-imag (second imag))
         (real-length (- high-real low-real))
         (imag-length (- high-imag low-imag))
         (real-by (/ real-length width))
         (imag-by (/ imag-length height)))
    (flet  ((do-it (start-x end-x start-cr)
              (loop
                 for x from start-x to end-x
                 for cr from start-cr by real-by
                 do
                   (loop 
                      for y below height
                      for ci from low-imag by imag-by
                      do
                        (let* ((c (complex cr ci))
                               (iterations-taken
                                (loop
                                   for z = c then (+ (* z z) c)
                                   for iteration from 0 below max-iterations
                                   while (within-radius z)
                                   count iteration)))
                          (set-colour image (truncate x) (truncate y) iterations-taken max-iterations))))))
      (let* ((end-x (truncate (/ width 2)))
             (threads (list (sb-thread:make-thread (lambda ()
                                                     (do-it 0 end-x low-real)))
                            (sb-thread:make-thread (lambda ()
                                                     (do-it (1+ end-x) (1- width) (+ (* end-x real-by) low-real)))))))
        (loop for thread in threads
           do (sb-thread:join-thread thread))))
    image))

Weblocks: Presentations

2008-04-13T14:45:00.000-04:00

When Slava set out to write Weblocks, he claims to have a goal to never write HTML again. The way he proposed to accomplish this was through the use of presentations. You can see an example of his UI-DSL. I don't claim to understand the UI-DSL but I do understand how presentations work and I like them!

I set out to add support for money for something I am working on. So first, I wanted to be able to validate/display a number. Simple enough. First thing I did was define a new type so I can change it later into something that handles currencies properly:

(deftype money () 
  'number)

There are basically two things you need to be able to do (depending on context): parse and display. Obviously, presentations are responsible for the display while parsers are responsible for ... parsing!

(defun parse-money (string)
  (read-from-string string))

(defun format-money-display (amount)
  ;; Note the extra "$"
  (format nil "$~4$" amount))

(defun format-money-input (amount)
  (format nil "~d" amount))

The reason there are two format functions is that you need to format the value for display or for editing. The latter is named format-money-input.

The protocol calls the generic functions weblocks:typespec->view-field-presentation and weblocks:typespec->form-view-field-parser depending on what the scaffold is rendering. The purpose of these functions is to take a typespec and create the corresponding presentation or parser.

You can have form scaffolds in addition to the regular scaffold. You would use the form scaffold when the method of display would be different. For example, for a boolean input you would use a checkbox for form input, whereas when simply rendering for display, you could use "true" or "false" or "yes" or "no".

In this case, I don't need anything this drastic, so I defined the functions as follows:

(defmethod weblocks:typespec->view-field-presentation (scaffold
                                                       (typespec (eql 'money)) args)
  (values t (make-instance 'money-presentation)))

(defmethod weblocks:typespec->form-view-field-parser ((scaffold form-scaffold)
                                                      (typespec (eql 'money)) args)
  (values t (make-instance 'money-parser)))

In this case, the money-presentation and money-parser types are just tags to make the generic function machinery work. The types are defined as follows:


(defclass money-presentation (weblocks:text-presentation weblocks:input-presentation)
  ())

(defclass money-parser (parser)
  ()
  (:default-initargs :error-message "a money value (for example, 100.51 or 4.52)")
  (:documentation "A parser designed to parse strings into
  money."))

Using :default-initargs you can define an error message that will be seen when parsing fails (for whatever reason).

When Weblocks has your parser and presentation types, it then calls the following generic functions depending on the rendering context:

weblocks:print-view-field-value

weblocks:parse-view-field-value

weblocks:render-view-field-value

You won't believe it, but there is barely any HTML involved. I love it!


(defmethod weblocks:print-view-field-value (value 
                                            (presentation money-presentation)
                                            field view widget obj &rest args)
  (declare (ignore args))
  (format-money-display value))

(defmethod weblocks:parse-view-field-value ((parser money-parser)
                                            value obj
                                            (view form-view) (field form-view-field)
                                            &rest args)
  (declare (ignore args))
  (declare (optimize safety))
  (ignore-errors
    (let* ((presentp (text-input-present-p value))
    (money-value (when presentp
                          (parse-money value))))
      (values t presentp money-value))))

(defmethod weblocks:render-view-field-value (value (presentation money-presentation)
                                             (field form-view-field)
                                             (view form-view)
                                             widget obj &rest args)
  (declare (ignore args))
  (render-text-input (view-field-slot-name field)
                     (format-money-input value)
                     :maxlength 50))

An example of usage would be:

(defclass transaction ()
  ((id :accessor transaction-id)
   (date :initform (get-universal-time)
         :accessor transaction-date
         :initarg :date)
   (amount :initform *default-money-value*
           :accessor transaction-amount
           :initarg :amount
           :type money)))

And that is all you need to add your own reusable type to Weblocks. Not bad. Haven't added a date type yet, but will soon.

Update: Generating DocBook output using Common Lisp and SBCL

2008-02-25T16:09:00.000-05:00

Referencing yesterday's post.

Since Jason asked for the source code, I figured I would post it in a blog instead of a comment as it is more annoying to write a medium-sized comment.

Be warned, it will only work in SBCL and on Linux :-) You need to install docbook-utils (which is apparently the old way of doing things.) On Ubuntu, apt-get install docbook-utils should do you. Here are the files in my little demo:

ebook.lisp: The "EBook". Contains all the source code for translation.

introduction.lisp: A file containing a single chapter.

This code is a hackjob so please keep the pointing and laughing to a minimum. Especially docbook-tree-to-xml-string. There are so many things wrong with that function!

The way I use it is I start up Slime, edit ebook.lisp and use C-c C-l which reloads the file into the Lisp image.

Enjoy and leave comments if you have any questions.

Generating DocBook output using Common Lisp and SBCL

2008-02-25T00:32:00.000-05:00

I've been a bit busy lately with Sohail 3.0 and an unexpected trip to Toronto (still here for a week) so I haven't had much time for much blogging.

Anyway, one of the things I've always wanted to learn was DocBook. Today I had a bit of down time so I downloaded the DocBook crash course. Oh boy. XML... If Java could be a markup language, it would be XML. If only I could get rid of the redundancy. Long story short, I thought of CL-WHO to generate the XML. Normally, CL-WHO is used to generate HTML, but it actually knows very little about HTML. To get CL-WHO to generate XML, all you need to do is set the prologue and mode to XML. To do this, execute the following at the REPL:


(setf (cl-who:html-mode) :xml)
;;; This is printed before anything else
(setf cl-who:*prologue* "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>")

For sample output, evaluate the following at the REPL:


(cl-who:with-html-output-to-string (s nil :indent t :prologue t)
  (:people
    (:person :id "1" (:firstname "Sohail") (:surname "Somani"))
    (:person :id "2" (:firstname "Heinz") (:surname "Ketchup"))))

Which generates:


<?xml version=\"1.0\" encoding=\"UTF-8\" ?>
<people>
  <person id=\'1\'>
    <firstname>
      Sohail
    </firstname>
    <surname>
      Somani
    </surname>
  </person>
  <person id=\'2\'>
    <firstname>
      Heinz
    </firstname>
    <surname>
      Ketchup
    </surname>
  </person>
</people>

The workflow is pretty straighforward:

Write CL-WHO document

Convert document to XML

Write to file

Run through docbook2<target>

Here is a "real example" where by "real" I mean copied from the above mentioned ebook:


(defparameter *book*
  `(:book :lang "en"
          (:bookinfo 
           (:title "Hello, world!")
           (:authorgroup
            (:author (:firstname "Sohail")
                     (:surname "Somani")))
           (:abstract
            (:para (:application "twiddle")
                   "is an application specially designed to do nothing
                   you would ever want"))
           (:keywordset
            (:keyword "twiddle")
            (:keyword "sample application")))
          ,(docbook-part "introduction.lisp")
          (:chapter 
           (:title "Zomg")
           (:sect1
            (:title "Testing")
            (:para
             (:segmentedlist
              (:segtitle "Name")
              (:segtitle "Occupation")
              (:segtitle "Favourite food")
              (:seglistitem
               (:seg "Tux")
               (:seg "Linux Mascot")
               (:seg "Herring")))
             (:ulink :url "http://www.kde.org"
                     "My favourite website"))))))

(docbook2pdf *book*) ;; actually also launches pdf reader :-D

So now, with Emacs and Slime (C-c C-l specifically!) I have a fully programmable DocBook IDE. Not to mention that I can use Lisp. Leave a comment if you are actually interested in the code :-)

Experience report: Common Lisp and OpenGL

2008-01-30T14:15:00.000-05:00

I am working through the (in)famous OpenGL Red Book using cl-opengl(-thomas). Who is this Thomas guy anyway?

I just thought I would post my experience about it so far.

I considered just using C or C++ to work through the examples but the thought of the turnaround time before something was running was bugging me. So I decided to use Common Lisp.

First of all, using clbuild was a smart idea. I additionally set up Emacs+Slime to be able to use the clbuild core or using the default core. I currently have a couple of projects and don't use clbuild for the others. The .emacs is quite ugly as a result but does what I need it to ;-)

Secondly, cl-opengl uses generic functions instead of direct function callbacks. At first, I did not like this deviation from the way OpenGL normally works (via callbacks) but now I have come to appreciate it. One benefit is that there are (apparently!) no global variables. Secondly, there is a lot of nice stuff you can do with generic functions that you cannot do with function callbacks and cl-opengl takes full advantage of this fact.

Thirdly, I was afraid that it might not perform well enough but it turns out that I haven't reached any part of the book yet that requires absolute performance (or it is fast enough!) I'm told that choice of language should not generally be an issue if you have done things right so that is encouraging.

Last, but not least, Emacs + Slime for development of the examples is awesome. I can modify the definition of the display code at runtime and the changes show up. That is very, very useful for understanding (for example) how functions like gluLookAt work.

In general, I believe the experience has been better than it would have been had I used C or C++ for going through the book's examples.

Getting started with clbuild and opengl

2008-01-29T15:42:00.000-05:00

A script to update/install the latest versions of all the most important Common Lisp packages.

-- clbuild project page

clbuild is a nice way to keep up to date on the latest libraries. An advantage over ASDF-INSTALL is that it can retrieve from more than just http. Look at Bill Clementson's blog for a good overview on how to get started. This post is about how to get started with cl-opengl(-thomas) with clbuild.

Once you have retrieved clbuild (lines prefixed by $ are what you would type in, everything else is output):


$ cd /path/to/clbuild
$ ./clbuild build cl-opengl
The following extra dependencies were found: alexandria babel cffi trivial-features
include dependencies in update? (Y/n)y
UPDATE darcs pull alexandria
Pulling from "http://common-lisp.net/project/alexandria/darcs/alexandria"...
No remote changes to pull in!
UPDATE darcs pull babel
Pulling from "http://common-lisp.net/~loliveira/darcs/babel"...
No remote changes to pull in!
UPDATE darcs pull cffi
Pulling from "http://common-lisp.net/~loliveira/darcs/cffi+lotsastuff"...
No remote changes to pull in!
UPDATE darcs pull cl-opengl
Pulling from "http://common-lisp.net/~loliveira/darcs/cl-opengl-thomas"...
No remote changes to pull in!
UPDATE darcs pull trivial-features
Pulling from "http://common-lisp.net/~loliveira/darcs/trivial-features"...
No remote changes to pull in!
update complete
20 system definition files registered
; loading system definition from
; /home/sohail/src/thirdparty/clbuild/systems/cl-ppcre.asd into
; #
; registering # as CL-PPCRE
Loading cl-glu...
Loading cl-glut-examples...
Loading cl-glut...
Loading cl-opengl...
Dumping monster.core...
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into /home/sohail/src/thirdparty/clbuild/monster.core:
writing 2976 bytes from the read-only space at 0x01000000
writing 5424 bytes from the static space at 0x01100000
writing 33984512 bytes from the dynamic space at 0x09000000
done]

You can start the core as follows:


sbcl --core monster.core

Now, you might think you can just call (glut:init) and be off to the races, but you would be wrong:


* (glut:init)
*** glibc detected *** sbcl: free(): invalid pointer: 0x080876a8 ***
*** lockup ensues ***

The problem here is that when clbuild dumped core, the pointers for command line arguments are saved along with it. Unfortunately, these are FFI pointers and so the values are invalid. When you call glut:init, it tries to free these pointers which results in the lockup above. Luis Oliveira (luis on #lisp!) suggested that this is something CFFI should handle and said he would make a note of it.

In the meantime, you can execute the following to get around it:


* (progn (setq glut::*argcp* (cffi:null-pointer) glut::*argv* (cffi:null-pointer)))
#.(SB-SYS:INT-SAP #X00000000)

And now, you are good to go:


* (glut:init)
; No value
*

Not very clever.

2008-01-24T19:50:00.000-05:00

I've just been formally adding the notion of fixtures to my CLSQL-backed application using Postgres SQL. Fixtures are fixed scenarios for your application that you can run tests against. Atleast that is what I call them!

One of the tasks when dealing with testing database applications is that you have to populate the database for part of your tests. The problem is that you have to also empty the tables before running the same set of tests again otherwise your results are either not repeatable or you will accidentally violate some uniqueness constraints. For example, you might have some users table and one of the uniqueness constraints applies to email addresses.

I came up with a really clever way of keeping the database clean during testing by abusing transactions (hint: whenever someone says they did something clever, it usually isn't!) The idea was to begin and always rollback a transaction for each fixture. This way, the database never actually got populated. Score one for me. The code looks something like this:


(defmacro with-no-db-side-effects (&body body)
  `(progn
     (clsql:start-transaction)
     (unwind-protect
          (progn ,@body)
       (clsql:rollback))))

(defmacro def-fixture (name args &body body)
  `(defun ,name ,args
     ,@body))

(defmacro with-fixtures ((&rest fixtures) &body body)
  `(with-no-db-side-effects
     (let (
           ,@(loop for fixture in fixtures
                collect `(,fixture (,fixture))))
       (declare (ignorable ,@fixtures))
       ,@body)))
...
(def-fixture fixture-a ()
  (populate-database))
...
(test test-something-specific-about-scenario-a
  (with-fixtures (fixture-a)
    (validate-foo)
    (validate-bar)))

Pretty clever (remember the above hint!) It worked as I expected.

At some point during the testing, you must also test the integrity of the relational model. I think you must do this because the integrity of your database should not solely be protected by the application. The IT department will always figure out a way to futz with your data!

One way in which you might try to test the integrity of your database is by entering some data that should be unique. You might try and add the same user twice, for example. So I did:


(test test-something-specific-about-scenario-a
  (with-fixtures (fixture-a)
    (validate-foo)
    (validate-bar)
    (signals duplicate-key-error (insert-duplicate-user))))

Which immediately results in:

Error POSTGRESQL-ERROR / ERROR:  current transaction is aborted, commands ignored until end of transaction block

Duh! If a query fails within a transaction, you are supposed to roll it back. It especially doesn't make any sense for PGSQL to execute any more of my commands until I rollback the transaction.

Oh well, it was almost clever. I wonder how people solve this problem with testing? I guess another way around it might be to force your fixtures to tell you which tables they populate:


(def-fixture fixture-a (:view-classes '(user foo bar))
  ...

Then the with-fixtures macro collects all the view classes and does a clause-less delete:


(defmacro with-fixtures ((&rest fixtures) &body body)
  (let ((tables (collect-all-tables-from-view-classes-of-fixtures fixtures)))
    `(unwind-protect (progn ,@body)
       (progn ,@(loop for table in tables collect `(clsql:delete-records :from ,table))))))

Clever!

Update: Still not very clever as the success of the above depends on the order of deletion. Dang it.

cl-selenium moved to common-lisp.net

2008-01-20T22:35:00.000-05:00

CL-Selenium, a project that I use/contribute to is now located at http://common-lisp.net/project/cl-selenium.

A little bit about the project:

Selenium is a test tool for web applications. You might use Selenium as a foundation for acceptance or functional testing. CL-Selenium is a Common Lisp interface to Selenium.

Right now, it is at version 0.1 as it is very new but it is quite usable. See the getting started tutorial if you don't believe me. As a bonus, it is now adsf-installable!

Thanks to the common-lisp.net guys, whoever you are. Thanks also to Matt Kennedy for starting up the project!

Some useful CLSQL helper functions

2008-01-19T16:49:00.000-05:00

Quite often, you need to query the database for when all values equal something or the other. For example, you might look for an authenticated user as follows (in SQL):


SELECT USERS.* FROM USERS WHERE USER_LOGIN='sohail' AND USER_PASSWORD='myhashedpassword'

Of course, in the year 2008, no one writes their own SQL anymore (or so Rails propaganda would have you believe!) So you use something like CLSQL and end up writing something like:


(clsql:select 'user :where [ and [ = [ user-login ] "sohail" ] [ user-password ] 'myhashedpassword' ])

Certainly more Lispy but still quite annoying. The Rails and Django guys have you write something that looks like:


ModelObject.find(id=5)

I've written a couple of helper functions for CLSQL (reproduced below) that let you write:


CL-USER> (find-one 'user :user-login "sohail" :user-password "myhashedpassword")
#<USER {B47D0C9}>
CL-USER> (find-all 'user :user-site-id 3)
(#<USER {B729209}> #<USER {B72AD81}>)

Makes it a lot easier to write bespoke queries without resorting to CLSQL's bracket syntax or SQL itself.

The code is here (would appreciate any comments as to how to clean it up a bit!):


(defun find-all (type &rest args &key (clause-op 'and) &allow-other-keys)
  (if (> (length args) 0) ;; if there are any filters to apply
      (let ((expressions (loop for (k v) on args by #'cddr
                              collect
                              (let ((op '=)
                                    (value v))
                                (make-instance 'clsql-sys:sql-relational-exp
                                               :operator op
                                               :sub-expressions
                                               (list (make-instance 'clsql-sys:sql-ident-attribute :name k :qualifier nil :type nil)
                                                     value))))))
        (clsql:select type :flatp t
                      :where (make-instance 'clsql-sys:sql-relational-exp
                                            :operator clause-op
                                            :sub-expressions expressions)))
      (clsql:select type :flatp t)))


(defun find-one (&rest args)
  (let ((result (apply #'find-all args)))
    (if (= 1 (length result))
        (first result)
        (error "More than one result returned when only one expected!"))))

Enjoy!

Getting started with cl-selenium

2008-01-14T02:54:00.000-05:00

I've created some documentation for the cl-selenium package. You can find it here. Let me know if you have any issues.

Update: CL-Selenium has been moved to http://common-lisp.net/project/cl-selenium/tutorial.html.

Weblocks: starting with a blank slate

2008-01-09T00:26:00.000-05:00

If you do the customary Hello World application in Weblocks, the UI looks something like this:

The code to create this page is:


(weblocks:defwebapp 'our-application)
(defun init-user-session (comp)
   (setf (weblocks:composite-widgets comp)
         (list "Hello!")))
(weblocks:reset-sessions)
;; Starts the server on localhost:8080
(weblocks:start-weblocks)

This minimal application brings in the following CSS files:

layout.css

dialog.css

main.css

And the following Javscript files:

scriptaculous.js

builder.js

shortcut.js

weblocks.js

dialog.js

Additionally, scriptalicious brings in a bunch of more dependencies that double the number of JS files.

The JS files are obviously what give you the nice Ajaxian effects and desktop application-like feel when you work with Weblocks widgets. However, I typically like to start from scratch so I can control what the framework brings in.

When you instantiate your Weblocks application (via weblocks:defwebapp), the variable weblocks:*application-public-dependencies* is set to a default list:


CL-USER> weblocks:*application-public-dependencies*
(#P"stylesheets/layout.css" #P"stylesheets/main.css" #P"stylesheets/dialog.css"
#P"scripts/prototype.js" #P"scripts/scriptaculous.js" #P"scripts/shortcut.js"
#P"scripts/weblocks.js" #P"scripts/dialog.js")

So that answers the question of where all those files come from. Set this list to nil and reload the page. You should get something like this:

If you look at the HTML for the page (through Firebug) you will see something like this:

Still pretty noisy. I don't care much about the meta tag, but I've got to get rid of the divs.

For every request, the function weblocks:render-page is called to actually generate the necessary HTML. This function just sends the head tag contents and is where all the external references are inserted into the output. It also opens the body tag but then calls the render-page-body function to actually output the body of the page. I redefine the function from:


(defmethod render-page-body (body-fn)
 (with-html
   (:div :class "page-wrapper"
   (render-extra-tags "page-extra-top-" 3)
   (htm (str body-fn))
   (render-extra-tags "page-extra-bottom-" 3))))

To:


CL-USER> (defmethod weblocks:render-page-body (body-fn)
          (weblocks:with-html
            (cl-who:htm (cl-who:str body-fn))))

Now if you reload the page, the HTML looks something like this:

To get rid of the footer, redefine the after method on render-page-body to do nothing (or remove it altogether);


CL-USER> (defmethod weblocks:render-page-body :after (rendered-html))

Now the HTML looks like:

The divs come from our init-session function where we defined it to be:


(defun init-user-session (comp)
   (setf (weblocks:composite-widgets comp)
         (list "Hello!")))

That was enough to keep me happy however. Hope that helps!

Code coverage in SBCL

2008-01-09T00:21:00.000-05:00

This is the most useful thing since macros: sb-cover.

No nonsense code coverage:


;;; The code coverage module
(require :sb-cover)

;;; Enable instrumentation
(declaim (optimize sb-cover:store-coverage-data))

;;; Force recompilation with instrumentation
(asdf:oos 'asdf:load-op :my-project-test :force t)

;;; Run the tests!
(my-project-test::run-all-tests)

;;; Create the report
(sb-cover:report "/tmp/report/")

;;; Disable instrumentation
(declaim (optimize (sb-cover:store-coverage-data 0)))

See Code coverage tool for SBCL for some nice output as well. I had no idea the cl-ppcre tests had such good coverage. Damn.

Handling vendor/third-party libraries in Common Lisp projects

2008-01-05T01:34:00.000-05:00

Any non-trivial application is going to have some third party dependencies. When working in C++, I have this very annoying habit to always have all third-party source in source control so that I could build it. And in fact, I would build the third-party libraries along with my own code. The benefits of this setup are:

No extra package installation besides compilers and build tools (ideally, I'd put these in as well!)

Package versions are fixed.

Free to patch libraries because SVN would usually merge nicely on library upgrades.

As we know, Common Lisp is compiled so this annoying habit should carry over nicely. Unfortunately, until very recently, I just didn't get how I would do it. Tonight, I threw together a small hack that works well enough which is all you can hope for at the end of the day.

Typically, my project layouts look like:


sohail@dev:~/project$ find . -maxdepth 1
.
./src
./test
./project.asd
./project-test.asd
./vendor

The vendor directory is where I usually stuff all the third-party dependencies. For example, you might have cl-fad as one of your dependencies. In the project's ASD file, you would add cl-fad as one of the modules you depend on. But the only problem is, how do you tell ASDF to look in ~/project/vendor/cl-fad for the asd files?

Obviously, the answer is asdf:*central-registry*, a list of directory pathnames that ASDF searches when asked to load something. But the problem is that I can check out my project anywhere on the file system, so I can't hardcode the paths.

So dynamically, we need to figure out the root of the checkout, call it *project-root*, get a list of all the ASDF-loadable packages in vendor and add their respective directories to asdf:*central-registry*. Simple enough, but I know more about pathnames than I ever wanted to know! Here is the code (put into project.asd):


(defparameter *project-root*
  (make-pathname :directory (pathname-directory *load-truename*)))

(defparameter *vendor-root*
  (merge-pathnames "vendor/" *project-root*))

(defparameter *asd-wildcard* 
  (merge-pathnames "*/*.asd" *vendor-root*))

(defparameter *all-asd-files*
  (directory *asd-wildcard*))

(dolist (asd-file *all-asd-files*)
  (pushnew (make-pathname :directory (directory-namestring asd-file))
           asdf:*central-registry*
           :test #'equal))

(defsystem myproject
   ...
   :depends-on (#:cl-fad))

Fun! Hopefully someone knows a simpler way to do this but this makes me happy for now!

A login widget for Weblocks

2008-01-03T13:50:00.000-05:00

Update: Thanks to some comments from readers, I've made an updated version. Please see the code here. Specifically, the concept of the auth-provider and the auth-login-fields have gone the way of the dodo and been merged into a singular auth-method.

In this earlier post, I abused the Weblocks dataform object to implement a widget for creating a new user.

I have since been heads down coding but last night, I teased the login/authentication logic apart from the rest of my app and I have created a login widget that should be usable as a component. The main concept is the concept of an authentication provider, called the auth-provider. This is the part that the application writer fills in. Here is a sample:


;;; Not always just user/login :-)
(def-auth-login-fields my-auth-login-fields
  ((site
    :initarg :site
    :accessor my-auth-login-fields-site
    :type string ; Weblocks types
    :initform nil)
   (login
    :initarg :login
    :accessor my-auth-login-fields-login
    :type string
    :initform nil)
   (password
    :initarg :password
    :accessor my-auth-login-fields-password
    :type password
    :initform nil)))

;;; In this instance, only a tag but could have state.
(defclass my-auth-provider ()
  ())

;;; Helper function
(defun make-my-auth-provider ()
  (make-instance 'my-auth-provider))

;;; The meat of it - return a generalized boolean. The result of this method is returned
;;; to the user
(defmethod auth-provider-authenticate ((map my-auth-provider) (fields my-auth-login-fields))
  (user-find-match (site-find (my-auth-login-fields-site fields))
                   (my-auth-login-fields-login fields)
                   (my-auth-login-fields-password fields)))

;;; The auth-provider and auth-login-fields are intimately connected.
(defmethod auth-provider-make-fields ((map my-auth-provider))
  (make-instance 'my-auth-login-fields :auth-provider map))

To use the login widget:


(defmacro current-user ()
  `(hunchentoot:session-value 'current-user))

(defun init-user-session (comp)  
  (with-flow (composite-widgets comp)
    ;; The value returned here is whatever was returned by
    ;; auth-provider-authenticate. The widget does not return
    ;; until auth-provider-authenticate returns not nil.
    (setf (current-user)
          (yield (make-instance 'login
                                :auth-provider (make-my-auth-provider))))
    (unless (current-user)
      (error "Um... User wasn't returned? This world is crazy. Atleast I still have my Lisp."))
  ...

Here is some code you should be able to copy-and-paste (you still need to write an auth-provider.) Let me know if you think there are improvements to be made. I'd like to submit this to Slava when I get a round tuit.


(defwidget login (weblocks:composite)
  ((auth-provider
    :accessor login-auth-provider
    :initarg :auth-provider)))

(defwidget login-form (weblocks:dataform)
  ())

(defmethod initialize-instance :after ((self login)
                                       &rest args
                                       &key auth-provider 
                                       (login-title "Login")
                                       &allow-other-keys)
  (declare (ignore args))
  (let ((fields (auth-provider-make-fields auth-provider)))
    (setf (widget-name self) "login-composite")
    (setf (composite-widgets self)
          (list (lambda () (with-html (:h1 (str login-title))))
                (make-instance 'login-form
                               :name 'loginform
                               :data fields
                               :ui-state :form
                               :allow-close-p nil
                               :on-success
                               (lambda (&rest args)
                                 (declare (ignore args))
                                 (answer self (slot-value fields 'result))))))))

(defclass auth-login-fields ()
  ((auth-provider
    :accessor auth-login-fields-auth-provider
    :initarg :auth-provider)
   (result)))

(defun authenticate (provider fields)
  (let ((result (auth-provider-authenticate provider fields)))
    (if result
        (progn
          (tbnl:log-message* "Successful authentication")
          (setf (slot-value fields 'result) result)
          (values t nil))
        (progn
          (tbnl:log-message* "Failed authentication: ~A" fields)
          (values nil '((foo "Authentication failed")))))))

;;; Weblocks hooks
(defmethod weblocks:update-object-from-request :around ((fields auth-login-fields)
                                                        &rest args)
  (multiple-value-bind (success failed-slots)
      (call-next-method)
    (if success
        (authenticate (auth-login-fields-auth-provider fields) fields)
        (values success failed-slots))))

(defmethod weblocks:render-form-controls ((obj auth-login-fields) 
                                          &rest keys 
                                          &key action 
                                          &allow-other-keys)
  (with-html
    (:div :class "submit"
   (render-button *submit-control-name* :value "Login"))))


(defmethod weblocks:dataform-submit-action ((obj login-form) data &rest args)
  (apply #'weblocks:update-object-from-request data :persist-object-p nil args))

;;; AUTH-PROVIDER GENERIC

(defgeneric auth-provider-authenticate (auth-provider fields)
  (:documentation "Return a generalized boolean to indicate
whether the fields provided authenticate a user."))

(defgeneric auth-provider-make-fields (auth-provider)
  (:documentation "Return the fields that auth-provider needs
to authenticate users. This is in the form of a new CLOS object instance.

The types of the fields should be specified to be one of the weblocks
types (see weblocks/src/types/*.lisp)"))

(defmacro def-auth-login-fields (name &body body)
  "A macro used to define login fields."
  `(defclass ,name (auth-login-fields)
     ,@body))

Compiling Common Lisp

2007-12-30T18:59:00.000-05:00

When a language is pre-compiled (like C or C++) there is a step of compiling and linking the source code into a form that can be executed directly on the target hardware. The assembling of source into an executable form is usually handled by a build system like SCons or Make.

The CPython implementation of the Python language uses an interpreter. There is no compile step involved (it is implicitly compiled to bytecode).

Common Lisp implementations are somewhere in between in that there is a compile step but you can still use them as interpreters. For example, SBCL creates these files called FASLs which seem to stand stand for "FASt Loading". Their use should be self-explanatory. The formats are implementation-dependent meaning that they are not portable between implementations (not like .class files for Java, for example.) I couldn't figure out what SBCL stores in it's fasls but my guess is that it is a bytecode.

While developing a library, it is useful to have an interpreter-like environment. However, when you are using a library, you don't want to load and recompile the source every single time. What you want to do is compile the library's files into FASL format and have your implementation load them when necessary.

That is where ASDF comes in. ASDF, which stands for "Another System Definition Facility, is a way to define your projects so that they can be compiled and loaded along with whatever they depend on, in the right order. The rest of this post covers what I did to get a project and a testing system setup. Installing ASDF is out of scope here but if you use SBCL, you already have it.

First, the file system layout that I tend to use:


sohail@dev:~$ cd project/
sohail@dev:~/project$ find . -not -iname "*.fasl" -and -not -iname "*~"
.
./src
./src/package.lisp
./src/code.lisp
./test
./test/package.lisp
./test/tests.lisp
./project.asd
./project-test.asd

ASDF looks for .asd (a system definition?) files in whatever paths are defined in the list asdf:*central-registry*. So the first thing you want to do is add the above path to the list. The way I did it (which is not optimal) is I modified ~/.sbclrc to include the following lines:


(require :asdf)
(push #p"/home/sohail/project/" asdf:*central-registry*)

Open up src/package.lisp in Emacs and enter the following:


(defpackage project
  (:use common-lisp)
  (:export some-function))

This uses the standard defpackage macro to define a Common Lisp package. A package is a mechanism to map symbols to names. The above exports a symbol called some-function. Next, open up src/code.lisp and enter the following:


(in-package #:project)

(defun some-function (a)
  (format *standard-output* "a is: ~A" a))

This uses the standard in-package macro to set the current package to be project. If you are using Slime, you can try loading code.lisp (C-c C-l) and if you haven't loaded package.lisp, you should get a message telling you that project does not designate a package. To make it work, load package.lisp and then code.lisp. In a large project, it would be impossible to remember which order to load things in.

The next thing to do is to make this loadable via ASDF. To do this, open up project.asd and enter the following:


;;; Define a package to define our system definition
(defpackage #:project-asd
  (:use :cl :asdf)) ;; Use ASDF (obviously!)

;;; All our definitions
(in-package project-asd)

;;; Our system is called project
(defsystem #:project
  :name "My project!"
  :components ((:module "src" 
                        :components ((:file "package")
                                     (:file "code"
                                            :depends-on ("package"))))))

We document that code.lisp depends on package.lisp. Another way to write the defsystem could have been:


(defsystem #:project
  :name "My project!"
  :components ((:file "src/package")
               (:file "src/code" :depends-on ("src/package"))))

I prefer using a module because if you have multiple modules that have dependencies, the dependencies are easier to define. For example, you might have a "model" module that depends on the "database" module.

Now go to the REPL and type (asdf:oos 'asdf:load-op #:project). Assuming you set up asdf:*central-registry* as above, you should get output like this:


; compiling file "/home/sohail/project/src/package.lisp" (written 30 DEC 2007 05:23:41 PM):
; compiling (DEFPACKAGE PROJECT ...)

; /home/sohail/project/src/package.fasl written
; compilation finished in 0:00:00
; compiling file "/home/sohail/project/src/code.lisp" (written 30 DEC 2007 05:23:37 PM):
; compiling (IN-PACKAGE #:PROJECT)
; compiling (DEFUN SOME-FUNCTION ...)

; /home/sohail/project/src/code.fasl written
; compilation finished in 0:00:00

Even though we told ASDF to "load" the system, since we hadn't compiled the files, ASDF compiled them for us, in the right order. Type (project:some-function 5) if you want to convince yourself that it worked!

Now we want to add a package to test our code. To do this, open up project-test.asd and enter the following:


(defpackage #:project-test-asd
  (:use :cl :asdf))

(in-package project-test-asd)

(defsystem #:project-test
  :name "Tests for my project!"
  :depends-on (#:project)
  :components ((:module "test"
                        :components ((:file "package")
                                     (:file "tests"
                                            :depends-on ("package"))))))

The only new thing here is the use of the :depends-on keyword argument to defsystem. Here, we are telling ASDF that before loading/compiling project-test, the project system must have done so successfully.

Mechanically, we add the following to test/package.lisp:


(defpackage #:project-test
  (:use :cl) ;; Could also use the project package but I like to qualify symbols
  (:export run-tests))

And the following into test/tests.lisp:


(in-package #:project-test)

(defmacro assert-string-equal (form1 form2)
  `(if (string= ,form1 ,form2)
       (print "Passed!")
       (print "Failed!")))

(defun run-tests ()
  (let (output)
    (let ((*standard-output*
           (make-string-output-stream)))
      (project:some-function 5)
      (setq output (get-output-stream-string *standard-output*)))
    (assert-string-equal "a is: 5"
                         output)))

Now save all those files, go back to the REPL and type:


(asdf:oos 'asdf:load-op #:project-test)
(project-test:run-tests)

You should see "Passed!" output.

Before you start writing your own test framework, take a look at FiveAM. You can also see my thoughts about FiveAM.

Happy Lisping!

My thoughts about FiveAM - Common Lisp testing framework

2007-12-27T21:43:00.000-05:00

I spent all day today adding some tests as I needed to do some refactoring. I wanted to choose a CL testing framework and came across Phil Gregory's great post: Common Lisp Testing Frameworks. I read through his review and as you can tell by the title, I chose to go with FiveAM. I won't go over what Phil covered in his post except to say that FiveAM has what I expect in a testing framework and more.

You can jump to the the bottom line.

Simple tests are defined simply:


(5am:test my-test-case
  (5am::is (= 2 (1+ 1)))

FiveAM has test dependencies:


(5am:test (my-other-test-case :depends-on my-test-case)
  (5am::is (= 3 (1+ (1+ 1)))))

FiveAM allows you to group tests using test suites:


(def-suite arith-tests :description "Arithmetic tests")
(in-suite arith-tests)
(... above tests ...)

However, the grouping is only useful for selecting which tests to run. You can't (for example) make one set of tests dependent on another set of tests. This makes the feature only useful for organizational purposes. It isn't a deal-killer especially since you can write a function to work around this limitation like the one below:


(defun add-test-dependency (a b)
  "Make test-suite a depend on test-suite b by making every test in a depend
   on every test in b"
  (let ((suite-a (safe-get-test a))
        (suite-b (safe-get-test b))
        suite-a-tests suite-b-tests)
    (maphash #'(lambda (sym obj)
                 (declare (ignore obj))
                 (push sym suite-b-tests))
             (5am::tests suite-b))
    (maphash #'(lambda (sym obj)
                 (declare (ignore sym))
                 (push obj suite-a-tests))
             (5am::tests suite-a))
    (loop for test-name in suite-a-tests
       do
         (let* ((test (safe-get-test test-name))
                (depends-on (5am::depends-on test)))
           (let ((new-depends-on
                  (if depends-on 
                      `(and ,depends-on ,suite-b-tests)
                      `(and ,@suite-b-tests))))
             (print test)
             (print new-depends-on)
             (setf (5am::depends-on test) new-depends-on))))))

In hindsight, a smarter way to do this would be to introduce a pseudo-test in b that depended on every test in b and then every test in a would depend on this pseudo-test. Ah well.

But my favourite feature is the fact that FiveAM lets you generate samples from a distribution of inputs and feed them into your functions to test. Here is one stupid example:


(test encode-password
  "Passwords are encoded as ALGO$SALT$HASHED-PASSWORD. This code tests
   that the structure is correct and that the components of the encoding
   pass sanity checks. In the case of encode-password the salt is randomly 
   generated."
  (for-all ((raw-password (gen-string 
                           :length (gen-integer :min 5 :max 10)
                           :elements (gen-character :code-limit (char-code #\~)
                                                    :alphanumericp #'alphanumericp
                                                    :code (gen-integer :min (char-code #\Space)
                                                                       :max (char-code #\~))))))
    (let ((encoded-pw (myapp::encode-password raw-password)))
      (validate-encoded-password encoded-pw))))

The for-all macro takes a list of generators and iterates through a set of samples for all the represented values. This is done through the use of generators (gen-string and friends.) In this case, I am iterating through a distribution of strings that generates a string between 5 and 10 characters long the contents of which are in the "interesting" ASCII character range. The body of the for-all macro is dedicated to encoding the password and validating that the encoding is sane. Although it isn't important, validate-encoded-password looks like:


(defun validate-encoded-password (encoded-pw)
  (destructuring-bind (algo salt hash)
      (split-sequence:split-sequence #\$ encoded-pw)
    (is (string= "md5" algo))
    (is (= 5 (length salt)))
    (is (= 32 (length hash)))))

The Bottom Line

5am is very suitable for testing in CL but test groups should really have the ability to take part in dependencies.

(Ab)using Hunchentoot's dispatch mechanism to implement authentication

2007-12-23T15:23:00.000-05:00

With any application in general, it is important to ensure that the user is allowed to use the system. This is known as authorization. The first step to authorizing a user is to authenticate the user or ensure the user is who they say they are. Once the user is authenticated, then the application can decide what operations/views the user is authorized to use. The de facto standard way of authenticating is by forcing the user to input a user name and password. <rant>I personally hate this.</rant>

With a stateful application, such as a desktop application, authentication is pretty straightforward: just authenticate at application launch.

Unfortunately, HTTP is stateless (keep-alives aside.) Continuation-based frameworks such as Weblocks totally remove the problem by allowing you to write your app as if it were stateful. It is quite beautiful. Continuation-based frameworks have their own uses but if they don't fit your needs, then you need a different approach.

The usual way to implement authentication for a web application to check if the client has been authenticated on each page request. Obviously, this is quite annoying if you have to do it yourself. Frameworks like ASP.NET handle this for you (\o/ frameworks) by some careful editing of XML files. As I understand it, you tell ASP.NET what resources are protected and how to authenticate when protected resources are accessed. You fill in the authentication blanks with some helper classes that MS wrote for you. ASP.NET then generates a random session ID and sets a cookie which is used in subsequent requests to the web application. Nothing special. This is wide open to MITM attacks if you don't use SSL or sufficiently secure your session ID.

Hunchentoot does none of the above but it has all the ingredients to make it possible. The idea is that we want to intercept every request and check if a protected resource is being accessed. If a protected resource is being accessed, then we need to either force authentication or pass the request along if the session is authenticated. One way to do this is to insert the appropriate code in every page using macros. Another way is to use Hunchentoot's dispatch table. Personally, I'm partial to the method covered here because it doesn't require you to remember to secure your pages. Another benefit with this method is that you can also protect non-function resources such as when you serve static content.

When Hunchentoot receives a request, it iterates through hunchentoot:*dispatch-table* executing each dispatch function. Each of these functions is meant to return a function that will serve the request when applicable. Therefore, Hunchentoot executes the first such function returned while iterating. Hopefully the solution that I am thinking of is clear: insert a dispatch function that gets called before all others that checks for an authenticated session and redirects to a login page if one is not found. Here is an example of such a dispatch function:


(defun check-login-dispatcher (request)
  (unless (or hunchentoot:*session*
              (starts-with (tbnl:script-name request)
                           "/public"))
    #'oopsie-need-to-login))

Where oopsie-need-to-login looks like:


(defun oopsie-need-to-login ()
  (page-body
    (:p "Before you can continue, you must login. For now,
         just " (:a :href "/public/auto-login" "click here"))))

And public/auto-login looks like:


(defun auto-login ()
  (hunchentoot:start-session)
  (hunchentoot:redirect "/"))

In real life, you would obviously not automatically log someone in and instead have the regular username / password form.

Further, to prevent session hijacking with Hunchentoot, you need to do atleast the following:

Use SSL (HTTPS)

;; See Hunchentoot documentation for the meaning of these variables
(setf hunchentoot:*use-remote-addr-for-sessions* t)
(setf hunchentoot:*use-user-agent-for-sessions* t)

You need to also redefine hunchentoot::get-next-session-id because it uses sequential session IDs which leaves you open to guessing attacks. Imagine an attacker logs in just before you and knows that the next session is N+1. Not fun.

The above method for authenticating a user is secure so long as the above three are implemented. I haven't done the third yet so I couldn't say what to do there. I think you need to generate a (theoretically) truly random number somewhere.

Update: You do *not* need to redefine hunchentoot::get-next-session-id. It turns out that information was made on a bad assumption that all the information going into the session id string was deterministic. On reading the code more, there are two elements of randomness inserted into the session string:

The session start time

A random string generated once per server

I think the above two are sufficient to make it secure for some value of secure. I believe the secrecy of the random string is important to the security. But I am no security expert!

RESTful handlers with Hunchentoot

2007-12-18T19:34:00.000-05:00

I am not quite sure what REST is but I know that following REST practices gives you URLs like http://www.mycompany.com/resources/94182. Pretty isn't it?

Django has a URL dispatcher which allows you to specify regular expressions that match incoming URLs and call a specific handler. If you wanted function resource_page to handle requests to URLs similar to the above, you would specify /resources/\d* as the regular expression. The slashes at the beginning and end of the regular expression are optional. Effectively, you are writing /?resources/\d*/?. This would match:

/resources/

/resources/123

/resources/123/

I'm not entirely sure that it would match /resources// (try it to see!)

This would not match /resources/abcd and other similar URLs.

In Django, the handler is written as:


def resource_page(request,resourceid):
  # ....

And the dispatcher is registered like:


urlpatterns = patterns('',
  (r"/resources/\d*",resource_page),
)

A little thing I forgot to mention was that if you want the matches to be bound to function arguments, you have to make sure the regex remembers them. In this case, one would really want to write:


urlpatterns = patterns('',
  (r"/resources/(\d*)",resource_page),
)

As is my nature, I decided I want this functionality as a Hunchentoot handler. Hunchentoot works pretty much the same way except you only specify dispatch handlers. When a request comes in, Hunchentoot iterates through the dispatch handlers and if one of them returns a function, that function is called to handle the request otherwise the default handler is called.

So the solution is obvious (I think!): I want to write a handler that matches the requested URL against a regex, binds any matches to function parameters and returns that function.

What I want to write in my code is something like:


;;; I like to be explicit about the slashes myself
(create-regex-dispatcher "^/resources/(\\d*)" #'resource-page)

This is obviously very simple once you have a regex engine. Fortunately, not only has Edi Weitz made a billion other libraries including Hunchentoot, but he has also written one of the fastest regex libraries, surpassing even Perl. Crazy.

Anyway, here is the code:


(defun create-regex-dispatcher (regex page-function)
  "Just like tbnl:create-regex-dispatcher except it extracts the matched values
   and passes them onto PAGE-FUNCTION as arguments. You want to be explicit about
   where the slashes go.

   For example, given:
   (defun blog-page (pagenum)
     ... )

   (push (create-regex-dispatcher \"^/blog/page(\\d+)\" #'blog-page)
         tbnl:*dispatch-table*)

   When the url blog/page5 is accessed, blog-page is called with pagenum 
   set to 5."
  (let ((scanner (cl-ppcre:create-scanner regex)))
    (lambda (request)
      (multiple-value-bind (whole-match matched-registers)
          (cl-ppcre:scan-to-strings scanner (tbnl:script-name request))
        (when whole-match
          (lambda ()
            (apply page-function (coerce matched-registers 'list))))))))

And a simple example for using it:


;;; If there is no match, id will be the empty string. 
;;; Should be a better way to handle this, but OK for now.
(defun resource-function (&optional id)
           (cl-who:with-html-output-to-string(s)
             (:html
              (:body
               (tbnl:log-message* "~A ~A")
               (if (or (null id)
                       (= 0 (length id)))
                   (cl-who:htm
                    (cl-who:str "No resource"))
                   (cl-who:htm
                    (cl-who:fmt "Resource ~A" id)))))))

(push (create-regex-dispatcher "^/resources/(\\d*)" #'resource-function)
      tbnl:*dispatch-table*)

Python decorators in Lisp, Part 3

2007-12-17T20:51:00.000-05:00

In this last post, I showed a way to implement Python's decorator syntax in Lisp which actually seemed to work for more than just myself!

What I did not show is how you can use this in regular source files. As mentioned previously, one way to add new syntax into Lisp is to tell the reader (via *readtable*) to call a reader macro when it encounters a particular pair of characters. So the answer to using this syntax in regular source files is to locally enable it by rebinding *readtable*. As always, it helps to write out what you would like to do:


(enable-py-decorator-syntax)

#@my-decorator
(defun my-function (x) ... )

#@my-decorator
(defun my-other-function (x) ... )

#@my-decorator
(defun yaf[yet-another-function] (x) ... )

(disable-py-decorator-syntax)

Quite simply, enable-py-decorator-syntax copies the current readtable and sets the dispatch function. It also assigns the original readtable to a variable so it can be reset. Conversely, disable-py-decorator-syntax does the opposite: it sets the current readtable to the original readtable and sets the auxiliary variable to nil. Without further ado, the code for these functions:


(defparameter *original-readtable* nil)

(defmacro enable-py-decorator-syntax ()
  "Turns on the decorator syntax"
  '(eval-when (:compile-toplevel :load-toplevel :execute)
    (%enable-py-decorator-syntax)))

(defun %enable-py-decorator-syntax ()
  (unless *original-readtable*
    (setf *original-readtable* *readtable*
          *readtable* (copy-readtable))
    (set-dispatch-macro-character #\# #\@
                                  #'|#@-reader|
                                  *readtable*)))

(defmacro disable-py-decorator-syntax ()
  "Turns off the decorator syntax"
  '(eval-when (:compile-toplevel :load-toplevel :execute)
    (%disable-py-decorator-syntax)))

(defun %disable-py-decorator-syntax ()
  (when *original-readtable*
    (setf *readtable* *original-readtable*
          *original-readtable* nil)))

Thanks to popeix for submitting the original post to reddit (mod it up!) The code for enabling and disabling the syntax was based on syntax.lisp.