CL-Chan (a CLSQL and Hunchentoot crash course) - Part 2

I've fallen to a fit of OCD in the past few days, which has compelled me to clean out my langnostic drafts folder. Yes, I have a drafts folder. It turns out that it contained something on the order of 12 almost finished articles that I just never got around to polishing. I'm still working on the authentication system, and poking around at the prospect of a real-time message board, but I'll also be either scrapping or refining+posting those forgotten drafts for the next few weeks. Starting with one about a year and a half in the making.

Start with Part 1 if you like.

---

Aaaand we're finally back.

This time we'll be looking at extending the board features and dealing with images, but first, I'm sure I'm not the only one tired of having to type out

(ql:quickload (list :hunchentoot :cl-who :clsql :formlets))
(load "cl-chan.lisp")

every time I want to load the package. Ideally, I'd like that to be a single statement ("Load all cl-chan files in the correct order, and do the same for each dependency"). That's one of the things an asdf-system definition lets you do[1]. First up, we've been keeping everything in one file, and we really shouldn't. At the very least, the model should be isolated since it's going to grow shortly. It's also typical for CL projects to have a separate package.lisp file[2]. Our package file is going to be very simple, since we don't export anything yet.

(defpackage :cl-chan (:use :cl :cl-who :hunchentoot :formlets :clsql)
  (:shadowing-import-from :clsql :select))
(in-package :cl-chan)

(connect '("localhost" "cl_chan" "me" "my password") :database-type :mysql)

(setf *default-caching* nil)

(setf formlets:*public-key* "my-public-key" 
      formlets:*private-key* "my-private-key")

(defvar *web-server* (start (make-instance 'hunchentoot:easy-acceptor :port 4242)))
(push (create-static-file-dispatcher-and-handler "/cl-chan.css" (merge-pathnames "cl-chan.css")) *dispatch-table*)

That should do it.

Next, lets pull out our testing data into a file named "testing-data.lisp" (we'll remove this later, but it will let you re-create your database fairly easily if you need to while we're still playing around)

(in-package :cl-chan)

(defun create-test-database ()
  (create-tables)
  (insert-test-data))

(defun drop-tables ()
  (dolist (i '(board thread comment))
    (drop-view-from-class i)))

(defun create-tables ()
  (dolist (i '(board thread comment))
    (create-view-from-class i)))

(defun insert-test-data ()
  (loop for i in (list (make-instance 'board :name "a")
                       (make-instance 'thread :board-id 1)
                       (make-instance 'thread :board-id 1)

                       (make-instance 'comment 
                            :thread-id 1
                            :author "me" :email "my@email.com" :subject "FRIST"
                            :body "I am most certainly the first poster in this fine establishment"
                            :date-time (now))
                       (make-instance 'comment 
                            :thread-id 1
                            :author "someone else" :email "you@fmail.com" :subject "Stop being a douchebag"
                            :date-time (now))
                       (make-instance 'comment 
                            :thread-id 1
                            :subject "You must be new here"
                            :body "trolled-softly.jpg"
                            :date-time (now))
                       (make-instance 'comment 
                            :thread-id 2
                            :body "[Something vaguely anti-semetic.]"
                            :date-time (now)))
        do (update-records-from-instance i)))

Next, pull out the model (the classes and related methods) into model.lisp. This'll actually be the most complicated individual file in the project.

(in-package :cl-chan)
(file-enable-sql-reader-syntax)

(defun now () (clsql-sys:utime->time (get-universal-time)))

;;;;;;;;;; board
(def-view-class board ()
  ((id :accessor id :initarg :id :type integer :db-constraints (:not-null :auto-increment) :db-kind :key)
   (name :reader name :initarg :name :type (string 5))
   (threads :accessor threads :db-kind :join
            :db-info (:join-class thread :home-key id :foreign-key board-id :set t))))

(defmethod echo ((board board))
  (with-html-output (*standard-output* nil :indent t)
    (:h1 (str (name board))) (:hr)
    (show-formlet post-thread-form) (:hr)
    (dolist (thread (threads board))
      (summarize thread))))

;;;;;;;;;; thread
(def-view-class thread ()
  ((id :accessor id :initarg :id :type integer :db-constraints (:not-null :auto-increment) :db-kind :key)
   (board-id :reader board-id :initarg :board-id :type integer)
   (comments :accessor comments :db-kind :join
             :db-info (:join-class comment :home-key id :foreign-key thread-id :set t))))

(defmethod summarize ((thread thread) &optional (preview-comment-count 5))
  (let* ((preview-comments (last (cdr (comments thread)) preview-comment-count))
         (omitted-count (- (length (cdr (comments thread))) (length preview-comments)))
         (first-comment (car (comments thread))))
    (with-html-output (*standard-output* nil :indent t)
      (:div :class "thread"
            (echo-header first-comment)
            (:a :href (format nil "/thread?thread-id=~a" (id thread)) "Reply")
            (:span :class "body" (:p (str (body first-comment))))
            (when (> omitted-count 0)
              (htm (:p :class "omitted" 
                       (str (format nil "~a comments omitted (and we don't do pictures yet)" 
                                    omitted-count)))))
            (dolist (r preview-comments) (str (echo r)))))))

(defmethod echo ((thread thread))
  (let ((first-comment (car (comments thread))))
    (with-html-output (*standard-output* nil :indent t)
      (:a :href "/board" "[Back]") (:hr)
      (show-formlet post-comment-form :default-values (list (id thread))) (:hr)
      (:div :class "thread"
            (echo-header first-comment)
            (:span :class "body" 
                   (:p (str (body first-comment))))
            (dolist (r (cdr (comments thread))) (str (echo r)))))))

;;;;;;;;;; comment
(def-view-class comment ()
  ((id :accessor id :initarg :id :type integer :db-constraints (:not-null :auto-increment) :db-kind :key)
   (thread-id :reader thread-id :initarg :thread-id :type integer)
   (author :reader author :initarg :author :initform nil :type string)
   (email :reader email :initarg :email :initform nil :type string)
   (subject :reader subject :initarg :subject :initform nil :type string)
   (body :reader body :initarg :body :initform nil :type string)
   (date-time :reader date-time :initarg :date-time :type wall-time)))

(defmethod echo ((comment comment))
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:div :class "comment"
          (echo-header comment)
          (:span :class "body" 
                 (:p (str (body comment)))))))

(defmethod echo-header ((comment comment))
  (with-html-output (*standard-output*)
    (:span :class "header" 
           (dolist (elem '(author email date-time subject))
             (htm (:span :class (format nil "~(~a~)" elem) (str (slot-value comment elem))))))))

Having chopped all that off, your cl-chan.lisp file should be left at

(in-package :cl-chan)
(file-enable-sql-reader-syntax)

(defmacro page-template ((&key title) &body body)
  `(with-html-output-to-string (*standard-output* nil :prologue t :indent t)
     (:html :xmlns "http://www.w3.org/1999/xhtml" :xml\:lang "en" :lang "en"
            (:head (:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8")
                   (:title (str ,title))
                   (:link :rel "stylesheet" :type "text/css" :href "/cl-chan.css"))
            (:body ,@body))))

(define-formlet (post-comment-form)
    ((thread-id hidden) 
     (author text) (email text) (subject text) (body textarea)
     (captcha recaptcha))
  (let ((new-comment (make-instance 'comment
                                    :thread-id (parse-integer thread-id)
                                    :author author :email email 
                                    :subject subject :body body
                                    :date-time (now))))
    (update-records-from-instance new-comment)
    (redirect (format nil "/thread?thread-id=~a" thread-id))))

(define-formlet (post-thread-form)
    ((author text) (email text) (subject text)
     (body textarea :validation ((longer-than? 5) "You need to type at least six characters here."))
     (captcha recaptcha))
  (let* ((thread-id (update-records-from-instance
                     (make-instance 'thread :board-id 1)))
         (new-comment (make-instance 'comment 
                                     :thread-id thread-id
                                     :author author :email email 
                                     :subject subject :body body
                                     :date-time (now))))
    (update-records-from-instance new-comment)
    (redirect"/board")))

(define-easy-handler (board-page :uri "/board") ()
  (page-template (:title "cl-chan")
    (let ((board (caar (select 'board :where [= [slot-value 'board 'id] 1]))))
      (echo board))))

(define-easy-handler (thread-page :uri "/thread") (thread-id)
  (let ((thread (caar (select 'thread :where [= [slot-value 'thread 'id] thread-id]))))
    (page-template (:title (or (subject (car (comments thread))) (id thread)))
      (echo thread))))

Now that we've broken everything up, start up a new file called cl-chan.asd and put this in it

;;; -*- Mode: Lisp -*-
(defpackage :cl-chan-system (:use :cl :asdf))
(in-package :cl-chan-system)

(asdf:defsystem cl-chan
  :version "0.001"
  :author "Inaimathi"
  :maintainer "you"
  :licence "AGPL"
  :description "A simple message board server"
  :depends-on (:hunchentoot :cl-who :clsql :formlets)
  :serial t  
  :components ((:file "package") (:file "model") (:file "cl-chan") (:file "testing-data")))

You should now be able to load up your lisp (with cl-chan/ as your working directory) and

> (ql:quickload :cl-chan)
To load "cl-chan":
  Load 1 ASDF system:
    cl-chan
; Loading "cl-chan"
..................................................
[package cl-chan]...
(:CL-CHAN)

Much better than doing it manually, and if you're showing off your app, you get to pretend you know Zach Beane for about two seconds until people realize what's going on :p. Now keep in mind that in this particular project, it hasn't saved us all that much. Even with our better organized code, we'd only really need to evaluate

(ql:quickload (list :hunchentoot :cl-who :clsql :formlets))
(load "package.lisp")
(load "model.lisp")
(load "cl-chan.lisp")
(load "testing-data.lisp")

in order to launch our little message board. Once you start adding files, you rapidly see the value of being able to use a single load statement instead, since a properly written .asd automatically loads them all in the correct order, as well as loading any noted dependencies. Note that once you understand what asd/package.lisp files are supposed to look like, you can auto-generate them with quickproject (thanks again, Zach).

Ok, it's about damn time we figured out what to do about these images we want, otherwise it's not much of an imageboard.

Alternatives Note

I'm going to continue the rest of the tutorial assuming we're taking a slightly reduced functionality, Lisp-only approach. It'll make the system really easy to set up, and increase its portability across various platforms (since everything we'll be using is a lisp library, it'll run anywhere you can load a thread-capable Common Lisp implementation). However, that's far from the only option.

The FFI Route

First, if you don't mind some installation headaches, you can use the faster-at-run-time :cl-gd (which is a set of UFFI bindings to the C-based GD graphics library).

Ostensibly, you can install libgd2-xpm or libgd2-noxpm (if you don't know the difference, just use the first one) and then (ql:quickload :cl-gd). And if that works for you, fantastic, you lucky fucker. Before you celebrate though, make sure to try out an example or two, because I thought it really was this easy to begin with.

If you're getting undefined alien function errors, as I did, you'll actually need to install the debian package from the lenny repos. If you're already running lenny, just do apt-get install cl-gd, otherwise you'll need to add

deb http://ftp.us.debian.org/debian/ lenny main contrib

to your /etc/apt/sources.list file, then run apt-get install cl-gd. I have no idea what issues you'll run into with lisps other than SBCL on systems other than Debian linux. Which is why I'm doing the portable thing in the actual tutorial.

The Lazy Bastard Route

Don't let the name throw you, it may be a legitimate option, depending on the circumstances. Basically, instead of dicking around with native libraries, or FFI calls, you just load up :trivial-shell and do something like

(shell-command (format nil "convert ~a -resize 300\\> ~a-preview.jpg" image-file image-name))

The performance on it sucks donkey dong, and it's not portable to non-posix-compliant platforms, and it requires you to have ImageMagick installed on the deployment environment, and it means you need to handle server-side image naming yourself (which we were going to do anyway) to avoid shell injection attacks. However, it's one line of code and it covers conversion for pretty much every graphical format under the sun (the main tutorial will be doing things the hard way, so you'll fully appreciate the simplicity of shelling out). If you can afford those hits, it's not a bad option.

I'll be continuing with the pure-Lisp version for portability purposes, and that gives us a bit of a problem. Unlike the "FFI" and "Lazy Bastard" options outlined above, Common Lisp doesn't have a general image-formatting library. We'll need to use separate libraries (and slightly different processes) for different image formats. Three in all, since we want to fully implement the 4chan formats; ch-image for JPEGs, imago for PNGs and skippy for GIFs. That's a pretty obvious place to apply method calls, actually, so lets start by formalizing the process for a single image type, then extending it to the others.

There are exactly two things we'll want to do to an incoming image: store the original, and store a 250x250 pixel proportional preview image. Before we get to that, we'll need to include a new library. :cl-fad will give us some easy ways of dealing with files on disk, so add it to your asd file package.lisp and load it into your REPL too. While we're at it, lets add the image manipulating libraries and the new file "images.lisp" into the mix.

;;; cl-chan.asd

...
:depends-on (:hunchentoot :cl-who :clsql :formlets :cl-fad 
                            ;; image related
                            :imago :skippy :ch-image)
...
:components ((:file "package") (:file "model") (:file "cl-chan") (:file "testing-data") (:file "images")))

;;; package.lisp

(defpackage 
    :cl-chan (:use :cl :cl-who :hunchentoot :formlets :clsql :cl-fad)
    (:import-from :imago :read-png :write-png) ;; resize
    (:import-from :ch-image :read-image-file :write-image-file) ;; resize-image
    (:import-from :skippy :load-data-stream :output-data-stream) ;; scale
    (:shadowing-import-from :clsql :select))
...

Note that we're importing the entirety of :cl-fad, but just select symbols from the image libraries. This isn't strictly necessary, but since we're going to be including three different utilities that do similar things, I get the sneaking suspicion that we'd get symbol collisions otherwise. I've imported relevant operations from all three libraries, even though we're starting out with JPGs only. Now then, start a new file called images.lisp, and add the following to it

(in-package :cl-chan)

(defclass image-upload ()
  ((name :reader name :initarg :name)
   (file-path :reader file-path :initarg :file-path)))

;;;;;;;;;; utility
(defun file-tuple->image-upload (hunchentoot-file-tuple)
  (destructuring-bind (file-path original-file-name mimetype) hunchentoot-file-tuple
    (make-instance (intern (string-upcase mimetype) :cl-chan)
                   :name (file-namestring file-path)
                   :file-path file-path)))

(defun store! (hunchentoot-file-tuple)
  (when hunchentoot-file-tuple
    (let ((img (file-tuple->image-upload hunchentoot-file-tuple)))
      (store-images! img))))

(defun new-dimensions (size width height)
  "Given a target size and width/height, returns a new width/height preserving aspect ratio. 
Does not scale images smaller than 250x250."
  (let ((ratio (max 1 (float (/ (max width height) size)))))
    (values (round (/ width ratio)) (round (/ height ratio)) ratio)))

;;;;;;;;;; PNGs
(defclass png (image-upload) ())
(defclass image/x-png (png) ())
(defclass image/png (png) ())

(defmethod store-images! ((img png))
  "Saves a preview and a big version of the given image in directories specified by the *big-dir* and *preview-dir* conf variables."
  (let* ((pic (read-png (file-path img)))
         (w (imago:image-width pic))
         (h (imago:image-height pic))
         (pic-name (make-pathname :name (name img) :type "png")))
    (copy-file (file-path img) (merge-pathnames pic-name *big-dir*))
    (multiple-value-bind (new-width new-height) (new-dimensions 250 w h)
      (write-png (imago:resize pic new-width new-height) 
                 (merge-pathnames pic-name *preview-dir*)))
    (namestring pic-name)))

So. What we just did was create a new class called image-upload, subclass it specifically for png, and write the store-images! method. :imago doesn't seem to provide a way to preserve aspect ratio for an image as you resize it, so we have to do that manually. I resisted the temptation to make it png-specific, because it's entirely possible that we'll need to call the same code as part of generating previews for the other formats.

Take a closer look at the file-tuple->image-upload. We're using the incoming file mimetype as a class name. That may sound like a bad idea, but as you'll see in a few minutes, we're going to be restrictive about what input we accept. It's just that in order to build a system we can extend later, we can't really be restrictive here.

Extensibility Note

The way we're going to restrict input is by doing server-side validation on the files our users will upload. That's a good idea, but doing just that will leave validation for this function elsewhere in the codebase. Without seeing that validation, the definition for file-tuple->image-upload can easily be mistaken for an injection attack vector (if we didn't validate, a user could send a bogus mimetype and cause us to spawn, for example, a pathname instead of an image. I can't think of an obvious attack that would be enabled by that, but it's still best to minimize vectors). Lets think through the alternatives here

Validate in file-tuple->image-upload

Whether we do it by writing an assertion to make sure that the incoming mimetype meets some criteria, or by creating a specific class using a cond statement, we run into the same problem: in order to add a new supported image type, it won't be enough to just evaluate a new store-images! method and new classes. We'll actually have to slightly re-write file-tuple->image-upload. That's bad; we'd like extensibility to be possible without involving edits to an existing cond in our package.

If you really, really feel nervous about leaving a naked class declaration like we did, you can add something along the lines of (assert (string= "image/" (subseq mimetype 0 6))) to the function, just to ensure the incoming is an image. Even doing that is going to come back for a bite of your ass if you decide to allow PostScript/PDF uploads in your forum (since both of those have the "application/something" mimetype).

Break file-tuple->image-upload up into methods

Instead of doing validation in-function, it's also possible to break the image-upload-creating function up into different methods. This is a viable, and technically more object-oriented, approach to the problem. I'm choosing not to go that way because it would mean defining something like

(defmethod make-image-upload ((mime (eql 'image/png)) hunchentoot-file-tuple)  
  "Handles PNG image-upload creation with the image/png mimetype"
  (destructuring-bind (file-path original-filename mime-string) hunchentoot-file-tuple
    (declare (ignore original-filename mime-string))
    (make-instance 'png :name (file-namestring file-path) :file-path file-path)))

(defmethod make-image-upload ((mime (eql 'image/x-png)) hunchentoot-file-tuple)
  "Handles PNG image-upload creation with the image/x-png mimetype"
  (make-image-upload 'image/png hunchentoot-file-tuple))

[repeat for every image type]

rather than merely something like

(defclass image/x-png (png) ())
(defclass image/png (png) ())

[repeat for every image type]

Yes, it's more object-oriented, but it's a lot more verbose, and it'll get even worse if you want to support an image type that has more than two common mimetypes. Keeping the amount of code you type to a minimum is very good practice for all the reasons you've probably already heard.

Note that we've actually got three subclasses for png. There's two reasons for that. I go over one in the Extensibility Note above. The other is that, while PNGs are technically supposed to be of mimetype image/png, I've seen several in the wild with image/x-png instead. Now, even though there are multiple mimetypes a PNG could have, we won't be dealing differently with each of them, so it's enough to create a png class with the appropriate methods, and then subclass that for individual mimetypes we plan to encounter. If you've seen others, feel free to add them.

Now that we have a way of dealing with images, lets set up the rest of our system to deal with them. First off, add the following lines to your package.lisp

(defparameter *image-storage-directory* "img")
(defparameter *big-dir* (merge-pathnames (make-pathname :directory `(:relative ,*image-storage-directory* "big"))))
(defparameter *preview-dir* (merge-pathnames (make-pathname :directory `(:relative ,*image-storage-directory* "preview"))))
(ensure-directories-exist *big-dir*)
(ensure-directories-exist *preview-dir*)
(push (create-folder-dispatcher-and-handler 
       "/img/" 
       (merge-pathnames (make-pathname :directory `(:relative ,*image-storage-directory*)))) 
      *dispatch-table*)

I'll format it a bit better in the code I check in, but it'll basically do the same thing. That's a specifier for a local image storage directory, and two specific subdirectories (which we ensure-exist just in case) where we'll be keeping the images that get uploaded to our board. The last few lines push our new storage folder onto the dispatch table so that Hunchentoot can serve the contained files. Now that we've got that, we'll need to change our formlets to accept an image file, and tell them what to do with it. We'll also need to add an image field to our comment class,

;;; model.lisp
...
(def-view-class comment ()
  ((id :accessor id :initarg :id :type integer :db-constraints (:not-null :auto-increment) :db-kind :key)
   (thread-id :reader thread-id :initarg :thread-id :type integer)
   (author :reader author :initarg :author :initform nil :type string)
   (email :reader email :initarg :email :initform nil :type string)
   (subject :reader subject :initarg :subject :initform nil :type string)
   (body :reader body :initarg :body :initform nil :type string)
   (date-time :reader date-time :initarg :date-time :type wall-time)
   (image :reader image :initarg :image :type string)))

...

State Note

You'll also need to re-create your database tables (or evaluate alter table COMMENT add column IMAGE varchar(255); against your database.

The actual SQL you need to run will vary slightly based on what database you're using. The above works with MySQL.

and change its echo method to output the image preview along with the comment. You'll also want to add the image echoing code to the thread echo method, since that does its own thing. In fact, it'd probably be a better idea to define a new echo-image method and call it in those three places.

;;; model.lisp

(defmethod summarize ((thread thread) &optional (preview-comment-count 5))
...
            (:a :href (format nil "/thread?thread-id=~a" (id thread)) "Reply")
            (echo-image first-comment)
            (:span :class "body" (:p (str (body first-comment))))
            (:br :class "clear")
...

(defmethod echo ((thread thread))
...
            (echo-header first-comment)
            (:span :class "body" 
                   (echo-image first-comment)
                   (:p (str (body first-comment))))
            (dolist (r (cdr (comments thread))) (str (echo r)))))))
...

(defmethod echo ((comment comment))
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:div :class "comment"
          (echo-header comment)
          (:span :class "body" 
                 (echo-image comment)
                 (:p (str (body comment)))
                 (:br :class "clear")))))

...

(defmethod echo-image ((comment comment))
  (when (image comment) 
    (with-html-output (*standard-output* nil :indent t)
      (:a :href (merge-pathnames (image comment) "/img/big/") 
          (:img :class "pic" :src (merge-pathnames (image comment) "/img/preview/"))))))

The last thing we need to do is change up the comment formlets so that they accept images (with validation) and add the appropriate image URI to the comments they produce.

;;; cl-chan.lisp

...
(defun validate-image (hunchentoot-file-tuple)
  (or (null hunchentoot-file-tuple)
      (and (funcall (file-type? "image/x-png" "image/png") hunchentoot-file-tuple)
           (funcall (file-smaller-than? 3000000) hunchentoot-file-tuple))))

...
     (author text) (email text) (subject text) (body textarea) 
     (image file :validation (#'validate-image "We accept PNGs smaller than 3MB"))
     (captcha recaptcha))
    (let* ((pic (store! image))
           (new-comment (make-instance 'comment
                                       :thread-id (parse-integer thread-id)
                                       :author author :email email 
                                       :subject subject :body body
                                       :date-time (now)
                                       :image pic)))
      (update-records-from-instance new-comment)
...

     (image file :validation (#'validate-image "We accept PNGs smaller than 3MB"))
     (captcha recaptcha))
  (let* ((thread-id (update-records-from-instance
                     (make-instance 'thread :board-id 1)))
         (pic (store! image))
         (new-comment (make-instance 'comment 
                                     :thread-id thread-id
                                     :author author :email email 
                                     :subject subject :body body
                                     :date-time (now)
                                     :image pic)))
...

Note the image validation function I was talking about. That makes sure that the file coming at file-tuple->image-upload is only going to be one of the options it can handle.

That should be that. If you head over to your browser now, you should be able to upload a PNG and see it kind of shittily rendered in the middle of your comment. If you'd rather do without the "shittily", add these two lines to your cl-chan.css

.pic { float: left; }
.clear { clear: both; }

Whew!

Ok, before you relax, remember, we've still got two more image types to handle, and one subtle bug to fix. Lets add those image types first.

;;; image.lisp

...

;;;;;;;;;; JPGs
(defclass jpg (image-upload) ())
(defclass image/jpeg (jpg) ())
(defclass image/pjpeg (jpg) ())

(defmethod store-images! ((img jpg))
  "Saves a preview and a big version of the given image in directories specified by the *big-dir* and *preview-dir* conf variables."
  (let ((pic-name (make-pathname :name (name img) :type "jpg")))
    (copy-file (file-path img) (merge-pathnames pic-name *big-dir*))
    (let* ((pic (read-image-file (merge-pathnames pic-name *big-dir*)))
           (w (ch-image:image-width pic))
           (h (ch-image:image-height pic)))
      (multiple-value-bind (new-width new-height) (new-dimensions 250 w h)
        (write-image-file (merge-pathnames pic-name *preview-dir*)
                          (ch-image:resize-image pic new-height new-width))))
    (namestring pic-name)))

also, we need to modify the validation functions on our formlets.

;;; cl-chan.lisp

(defun validate-image (hunchentoot-file-tuple)
  (or (null hunchentoot-file-tuple)
      (and (funcall (file-type? "image/x-png" "image/png" "image/jpeg" "image/pjpeg") hunchentoot-file-tuple)
           (funcall (file-smaller-than? 3000000) hunchentoot-file-tuple))))

...
     (image file :validation (#'validate-image "We accept PNGs or JPGs smaller than 3MB"))
...
     (image file :validation ((file-type? "image/x-png" "image/png" "image/jpeg" "image/pjpeg") 
                              "You need to upload an image of type PNG or JPG"
                              (file-smaller-than? 3000000) "Your file needs to be smaller than 3MB"))
...

That should do it.

We implemented JPGs ahead of GIFs because it's much closer to the PNG scaling we already did, but note the number of differences there.

1. the width and height arguments are ordered y x rather than x y
2. the pathname and image parameters to the write function are in a different order
3. the functions involved in reading/writing/resizing are named differently
4. the steps we need to take are in a different order because ch-image can't seem to read image files with no file extension. That means we copy the big one first, rename it, then read that instead of the original temp file

Those are all small differences that you nevertheless need to get right if you don't want a face full of errors or odd results (like that screenshot above) when you start your board up. Before we tackle GIFs and that subtle bug, let me just point out that someone who picked our "Lazy Bastard" route earlier has saved themselves all of this trouble, and probably has higher quality previews to boot. But we're here to learn things, so we're going the hard way. Now then.

;;; images.lisp
...
;;;;;;;;;; GIFs
(defclass image/gif (image-upload) ())

(defmethod store-images! ((img image/gif))
  "Saves a preview and a big version of the given image in directories specified by the *big-dir* and *preview-dir* conf variables."
  (let* ((pic (load-data-stream (file-path img)))
         (first-frame (aref (skippy:images pic) 0))
         (width (skippy:width pic))
         (height (skippy:height pic))
         (pic-name (make-pathname :name (name img) :type "gif")))
    (copy-file (file-path img) (merge-pathnames pic-name *big-dir*))
    (multiple-value-bind (new-w new-h) (new-dimensions 250 width height)
      (let ((new-pic (skippy:make-data-stream 
                      :width new-w :height new-h
                      :color-table (skippy:color-table pic))))
        (skippy:add-image 
         (skippy:composite first-frame
                           (skippy:make-image :width new-w :height new-h) 
                           :width new-w :height new-h)
         new-pic)
        (output-data-stream new-pic (merge-pathnames pic-name *preview-dir*))))
    (namestring pic-name)))

and the appropriate formlet changes. In fact, we'd really better pull out the image types into a separate variable so that we only need to change them in one place.

;;; package.lisp

...
(defparameter *allowed-image-fn*
  (file-type? "image/x-png" "image/png" "image/jpeg" "image/pjpeg" "image/gif"))

(defparameter *image-message*
  "You need a PNG, JPG or GIF smaller than 3MB")
...

;;; cl-chan.lisp

(defun validate-image (hunchentoot-file-tuple)
  (or (null hunchentoot-file-tuple)
      (and (funcall *allowed-image-fn* hunchentoot-file-tuple)
           (funcall (file-smaller-than? 3000000) hunchentoot-file-tuple))))

(define-formlet (post-comment-form)
...
     (image file :validation (#'validate-image *image-message*))
...

(define-formlet (post-thread-form)
      (image file :validation (*allowed-image-fn* *image-message*
                              (file-smaller-than? 3000000) 
                              "Your file needs to be smaller than 3MB"))
...

And that's that.

You'll notice that the GIF resizing process is a lot more complicated than what we had to do for PNGs or JPGs. That's because GIFs are potentially animated, so the Lisp library that handles them treats them as streams of images. That allows for better frame control, but it does mean that we need to

1. load the stream
2. pull out the first frame
3. resize that frame[3]
4. shove it into a fresh stream
5. write that new stream of one image

Once again, notice how much work the Lazy Bastards have saved themselves with that one line of code. Incidentally, had I known about Skippy's lack of ability to scale an image down, I probably would have gone with the lazy option myself and chucked portability in a fucking bin.

It's already done, so no sense in tearing out half of this column now. Especially since its been a good what... year and a half since I started it? Yeah, sounds like it's about time to get the FILDI out.

Really quickly before we go, I mentioned a subtle bug. We're letting Hunchentoot generate tempnames for our files. That's very simple, since we do nothing, but its internal name counter gets reset every time it shuts down. Which means that if you shut it down in production, new images are going to start clobbering your old ones. The easiest way to solve this is appending a timestamp to them. Between that and Hunchentoots' internal temporary file counter, we should be set in terms of unique names. Given how we use the name field of the image-upload class, the simplest way to do this is actually in file-tuple->image-upload.

(defun file-tuple->image-upload (hunchentoot-file-tuple)
  (destructuring-bind (file-path original-file-name mimetype) hunchentoot-file-tuple
    (make-instance (intern (string-upcase mimetype) :cl-chan)
                   :name (format nil "~a-~a" (file-namestring file-path) (get-universal-time)) 
                   :file-path file-path)))

Note the change in the line starting with :name. Ok, I've had enough of this bullshit. New codebase up at github, now get out.

Tune In Next Time (heh heh) For:

• finally getting to multiple boards!
• walking through the lazy option in its entirety!
• some better usability and UI, maybe!

---

Footnotes

1 - [back] - The other is put together a downloadable archive so that other Lispers can install your package through asdf-install, but we'll discuss that later.

2 - [back] - So that when someone else is using your package, they can go to one consistent place to see all the symbols you're exporting and including. I tend to put conf variables there too if there aren't very many of them, but they should probably be in their own conf.lisp file.

3 - [back] - Actually, there's no usable resize or scale option, so we just crop it to the top left.

Authentication Part 4.5 - Not

We don't need authentication
We don't need access control
No dark sarcasm in the network
Servers leave them kids alone

Housekeeping

Despite the authentication theme, this update is probably going to be a mishmash of content, giving how fast my head is spinning at the moment. First, I want to bring a couple things to your attention. Not quite enough to earn this post the "Intellectual Property Bullshit" tag, but interesting nonetheless.

Also, before I move on, I polished up what I went over last time, and put it up on github. The differences between what went up and what was discussed are minimal, though I did add some automated testing and polished off one or two odd corners that I glossed over in the writeup. I didn't commit a front-end at all, so you'll need to hook that up yourself if you plan to use it, but what's up there should give you all the plumbing you need. Let me know if that was a false statement.

It's not done yet, two-factor auth coming rather soon, but the existing API isn't going to change at this point. I may put another layer on top just to simplify the external interface, and maybe make it easier to expose this system as a web-service, but that's about it.

Not Authenticating

Before we go any further, lets take a look at some real-life systems to see how they handle the Authentication Problem. I doubt you'll be surprised.

IRC

This is the classic online communication protocol. In fact, if you like, we can go further.

Mail

Not Email. Old mail. The original dead-tree protocol, just in case IRC wasn't quite classic enough for you. They have one very important thing in common; neither does any kind of authentication. A user in IRC chooses a username each time they log in to a session. They may choose a different name each time, and another user may choose a name that belonged to someone else last time. Likewise, mail doesn't authenticate. There are optional, unvalidated fields on every envelope where someone can put a not-necessarily-correct return address, but that's it. Bottom line, you really don't know who you're talking to. If you want to, you need to authenticate them some other way. Either you know their handwriting, or you're familiar with their word frequency, or maybe you've exchanged keys in the past so that you can now verify who they are, but the channel itself provides you with none of this information. Further, you have no real guarantee that a message you send makes it to your intended target, or that you're getting all messages addressed to you, or that they aren't being observed/tampered with even if they do eventually get where they're going.

These are the prototypical unsecured channels, and they still[1] do a pretty decent job of putting humans in touch with one another in indirect ways. Mail used to be a fairly reliable line of communication, but I'm honestly having a hard time remembering the last time I got something other than spam or bills in the mail. I'm not entirely sure why, so I won't theorize. The key with IRC seems to be community size. It's a good bet that you can get some profitable conversation happening on smaller channels, but larger ones seem to exponentially attract various spammers.

The authentication system[2] is nonexistent. Moving on.

Message Boards

I'm not discussing forums yet. I'm instead referring to the various *aba/*booru-descended boards. These typically don't use authentication either, except for the moderators. They do tend to have the common feature of "tripcodes". Basically, hashes with varying levels of security depending on implementation. They don't let you know who you're talking to either, but it's at least semi-possible to verify that a given series of tripped messages come from the same source.

Moderation mostly seems to take the form of deletion passwords. That is, there doesn't seem to be a separate interface for mods, they just have the ability to remove content and hand out bans using an authentication they're given[3].

The key takeaways here are twofold. First, non-authentication is the norm. It's not only conceivable but usual to have authentication between endpoints handled entirely separately from the intended communication channel. Second, it's unnecessary to enforce authentication for the purposes of communication or publishing. When you're posting content or sending messages back and forth, it's typically enough to verify that a given set of messages/articles all have the same source without necessarily verifying what that source is. Moving on. Again.

Wikis

These sit between IRC and Forums in terms of authentication strength. Here, I'm talking about both actual wikis, and systems like Stackoverflow. The key is that there is a user account system[4], and it's not just for moderators, but it is optional. Anyone can view and contribute some sort of information, but there is an inner circle of trusted users that makes up a wiki's core community, and that core wields the really powerful brushes.

The authentication that does exist is, by and large, the same password based stuff that gets used everywhere regardless of security. Some of them use OpenID, which is a fantastic system in theory, but in practice seems to come down to a password system where four or five giant companies control the user databases for everyone[5]. I think we can do better.

Forums

We're talking about the standard phpBB-style forums, as well as stuff a-la Reddit and various social/news sites. By and large, these maintain their own user systems. I'm not going to make a blanket statement like none of them actually need your information to do the job they propose to, but it's at least partially true. This is the next level of authentication above wikis; you can view information without an account, but contributing any effort at all to the target community requires a registration. An effort is made to have people associate their identity with one account by tracking post numbers, karma, badges, or some combination of the above. That doesn't mean it happens, and in practice, spammers tend to commonly have vast networks of identities at their disposal if the potential audience is big enough. Really, these systems don't require the level of authentication they tend to have. I'm inclined to be cynical about it and say that they only want to have some sort of user estimate in hand, but that may not be the case.

Transaction Authorities

These are things like, oh, for example your bank. This isn't a publication system, there's a communication channel in place specifically to let you issue orders about resources that are ostensibly under your control. They tend not to use OpenID[6], and they tend to restrict passwords more than other organizations. These places have a vested, legitimate interest in knowing precisely who you are, keeping fake accounts as close to non-existent as possible, and having a traceable, consistent way of verifying where each command they're acting on came from.

The kicker here, the reason I get the feeling that these institutions are fine with enforcing crappy password and security practices for their users is that they don't really trust this whole internet thing. Here, let me regale you with a snippet from the TOU agreement my former bank puts forth

2.1 Security and privacy. You acknowledge that the Internet is not a secure medium and privacy cannot be guaranteed or ensured. -PC Mastercard Terms of Use

In other words, "sure have your account, we're still calling you, or expecting you to come into a branch physically for the big stuff". I'm not entirely convinced this is a bad idea.

Spectrum Summary

There's a huge number of different authentication strategies in use on the internet already. You can do most of what you need to without ever signing in to anything. There are a few things that require really strong, working security to do online. There are three potential reactions to this state of affairs.

1. Fuck It. We don't need authentication on the internet. Lets make more anonymous services, and allow communication to happen in a freehand, fully private way. We don't need strong security, and it shouldn't be assumed in public networks; if there's something you need good security for, do it in meatspace.
2. We're Good Enough. Half-assed authentication is good enough if no one looks too closely. It's there to keep honest people honest in any case, so improving it substantially isn't a big win, and exploiting it in a brute-force manner won't happen in ways we don't anticipate.
3. We Need Good Auth. There are at least some situations that require intelligent, secure, verifiable identification systems, so we may as well put one together. If for no other reason than to use it where it's absolutely necessary.

As evidenced by my 4-part (and sure to grow) series on authentication, I fall somewhere between groups 2 and 3. Mostly in 3, really, except that I agree that perfect security is probably more trouble than it's worth; I may talk about why I think that in the future, but you can probably work it out yourself. That said, the difference between digital crypto-systems and the traditional ones is that with the tools we've got, we can do a damn sight better than "keeping honest people honest". That's something to aspire to, and I aim to make a dent in the problem, at least.

---

Footnotes

1 - [back] - For a little while at least, in the case of mail.

2 - [back] - Which is what we're interested in here.

3 - [back] - Presumably one per user, though I guess I could imagine there being only one moderation password for a given board.

4 - [back] - Unlike the various message boards, which provide some trace of authentication capability without user accounts.

5 - [back] - Yes, everyone can technically host their own identity, I get the feeling that a vast majority of OpenID users just let Facebook handle it. I reserve judgment on whether that's a good thing.

6 - [back] - To put it mildly.

Erlang From Scratch

I mentioned earlier that I gave up on rebar[1], but I never actually wrote up the process I do use. So, here's a quick example in the form of an OTP-compliant echo server tutorial.

OTP-Compliant Echo Server Tutorial

The first thing you need to do is create a directory for your project, and give it a certain internal structure.

$: mkdir example
$: cd example
$: mkdir ebin src deps priv
$: cd ..
$: tree example
example
├── deps
├── ebin
├── priv
└── src

These all have specific purposes.

• src is where you'll keep all your .erl files. Really, you're supposed to keep other language sources in separate [lang]_src folders, but I put it all in here. I don't know if that'll come back to bite me in the ass. I'll report on it either way.
• ebin is where you put the results of compiling your .erls. Only your .erls, not your .cs, .pys, .javas or .lisps, please. I actually follow this one since everyone else seems to and it might actually matter for the purposes of someone else making use of my libraries. So interop. Fun.
• priv is where you put the results of compiling all your non-Erlang code. Note that since we'll be running the system from exapmle/, you should invoke any non-Erlang components with (for example) python -u priv/foo
• deps is where you put any code not part of your project, but that you depend on. I'm actually not too clear on whether you're supposed to copy all required files into deps directly, or whether you're supposed to arrange a tree of deps/(.*?)/(ebin|priv)/. Both approaches work, and there doesn't seem to be any big technical difference between them. I use the latter for preference.

That's the folder structure, now lets organize our src folder. To set up an OTP project, you'll need at minimum 4 files.

$: cd example/src
$: touch example.app example_app.erl example_sup.erl echo.erl
$: tree ../
../
├── deps
├── ebin
├── priv
└── src
    ├── echo.erl
    ├── example.app
    ├── example_app.erl
    └── example_sup.erl

example.app is your application definition. It gives Erlang an idea of how to deal with the rest of your files, and what kind of setup do expect. It seems that it doesn't have to reflect reality[2], but it's probably a good idea to get it as close as possible.

{application, example,
 [{description, "Something something dark side"},
  {vsn, "1.0"},
  {modules, [example_app, example_sup, echo]},
  {registered, [echo]},
  {applications, [kernel, stdlib, sasl]},
  {mod, {example_app, []}},
  {start_phases, []}]}.

The description and version are entirely flexible, and entirely up to you. modules specifies what modules this project will load, registered is a list of registered OTP processes we'll be running (just our echo server in this case), applications is a list of other Erlang systems we'll be including (you don't really need sasl, but I prefer the more detailed error reporting it gives you). The other two specify advanced startup behavior that I've yet to actually mess with myself. {mod, {Mod, Argument}} passes Argument to the function start in the module Mod. I can't remember what start_phases does, so it's either well beyond me or not particularly important.

Near as I can tell, example_app.erl just provides an interface to example.app for Erlang's standard application module.

-module(example_app).
-behaviour(application).
-export([start/2, stop/1]).

start(_Type, StartArgs) -> example_sup:start_link(StartArgs).
stop(_State) -> ok.

That's the function I mentioned earlier. We're passing it [] in this case, because it doesn't need any particular initializing information. Nothing much else to see here.

example_sup.erl is the supervisor process for our system. Its responsibility will be to monitor and restart the echo process in case of errors. OTP convention seems to be to name them with a _sup suffix.

-module(example_sup).
-behavior(supervisor).

-export([start/0, start_link/1, init/1]).

start() ->
    spawn(fun() -> supervisor:start_link({local, ?MODULE}, ?MODULE, _Arg = []) end).

start_link(Args) ->
    supervisor:start_link({local, ?MODULE}, ?MODULE, Args).

init([]) ->
    {ok, {{one_for_one, 3, 10},
          [{echo, {echo, start, []}, permanent, 5000, worker, [echo]}]}}.

start/0 and start_link/1 are the obvious hooks to start up the supervisor. The interesting part here is actually the contents of init/1. The first tuple is {SupervisionStrategy, Restarts, Time}. SupervisionStrategy tells the supervisor how to deal with an errored child; one_for_one means that it should merely restart the crashed process. There are a couple of other options that let you kill all other children, or just all children after the initial errorer in the starting sequence. That's... kind of creepy out of context.

If it catches more than Restarts errors in under Time seconds, it kills all, um, children. Then itself[3]. The list, of one in this case, modules after that specify various properties of the processes. The tuple specifies {Module, StartFn, StartArgs}, the list at the end is just the name of the module again because someone at Ericsson evidently thought that "repetition" is the same as "reliability", but the tuple at the front is actually something different. It's the module tag, which will be used to register this process. By convention, it's typically the same as the module name, but there's one situation I'll cover later where it's useful to do otherwise.

Moving right along to the actual echo.erl.

-module(echo).
-behaviour(gen_server).

-export([start/0, stop/0]).
-export([init/1, handle_call/3, handle_cast/2, handle_info/2,
         terminate/2, code_change/3]).

-export([echo/1]).

echo(Message) -> gen_server:call(?MODULE, Message).

handle_call(Message, _From, State) -> 
    {reply, {you_just_sent, Message}, State}.

%%%%%%%%%%%%%%%%%%%% generic actions
start() -> gen_server:start_link({local, ?MODULE}, ?MODULE, [], []).
stop() -> gen_server:call(?MODULE, stop).

%%%%%%%%%%%%%%%%%%%% gen_server handlers
init([]) -> {ok, []}.
handle_cast(_Msg, State) -> {noreply, State}.
handle_info(_Info, State) -> {noreply, State}.
terminate(_Reason, _State) -> ok.
code_change(_OldVsn, State, _Extra) -> {ok, State}.

Most of that is boilerplate. The only interesting parts are the export directive that specifies echo/1, the echo/1 function itself, and the lone handle_call/3 clause. All of which are entirely self explanatory for a basic echo server.

Now, lets start this fucker up!

$: cd ..
$: make
make: *** No targets specified and no makefile found.  Stop.

Dammit. That's right, we've got one more stop. Here's a basic, OTP-compatible Makefile. Trust me, you need this. It's slightly different than the one I'm using, mostly in the interests of clarity[4].

ERL = erl -pa ebin -pa priv

erl_start = -eval 'lists:map(fun (App) -> application:load(App), application:start(App) end, [sasl, example]).'

erl_stop = -s init stop

### Rules
all: 
        erlc -Wf -o ebin/ src/*erl
        cp src/*app ebin/

start: 
        $(ERL) -name example@127.0.1.1 $(erl_start)

clean:
        rm ebin/* deps/* priv/* 

This does a couple of things. First, make compiles all the *erl files in src into ebin, second it copies over the .app file, and finally, make start gives you an easier way of starting erl with all the relevant includes/startups than typing it all up each time. Now then.

$: make
erlc -Wf -o ebin/ src/*erl
cp src/*app ebin/
$: tree
.
├── deps
├── ebin
│   ├── echo.beam
│   ├── example.app
│   ├── example_app.beam
│   └── example_sup.beam
├── Makefile
├── priv
└── src
    ├── echo.erl
    ├── example.app
    ├── example_app.erl
    └── example_sup.erl
$: make start
[snip a whole bunch of startup notifications thanks to sasl]
(example@127.0.1.1)1> echo:echo(hello).
{you_just_sent,hello}
(example@127.0.1.1)2>

Tadaaah! You've just made a full OTP application from scratch, with no automated tools of any kind. Now that you know how fuckmotheringly tedious it is, I hope you'll come to the same conclusion I arrived at and write yourself something like this to automate the process[5]. Point of fact, I slowed my process waaaaay down for this piece. In reality, I got to the end in about 20 seconds with one invocation of erl-custom-template-project[6].

Ok, quit out of that with a C-c C-c. We've got the basics down. Time for a

Bonus Stage

We've got a single echo server running, but what if we wanted a few that all have mildly different behaviors? I've seen some beginners who think the solution is copy/pasting the existing echo.erl and chopping it up. In reality, Erlang is a little more object-oriented than Joe would have you believe. There is a bit of chopping involved, but only because we wrote the initial echo module without thinking about this situation. First off, its API needs to change to accept a process, rather than assuming one named the same as the ?MODULE.

...

-export([echo/2]).

echo(Proc, Message) -> gen_server:call(Proc, Message).

...

Second, we can't hard-code components that we'll want to change across processes.

...

handle_call(Message, _From, Reply) -> 
    {reply, {Reply, Message}, Reply}.

...

And we need a way of changing those components from the specification in the spawning supervisor.

...
-export([start/2, stop/1]).
...
%%%%%%%%%%%%%%%%%%%% generic actions
start(ProcName, Response) -> gen_server:start_link({local, ProcName}, ?MODULE, Response, []).
stop(ProcName) -> gen_server:call(ProcName, stop).

%%%%%%%%%%%%%%%%%%%% gen_server handlers
init(Response) -> {ok, Response}.
...

Finally, we need to modify our supervisor to take advantage of all this new modularity.

%% example_sup.erl
...

init([]) ->
    {ok, {{one_for_one, 3, 10},
          [{nice, {echo, start, [nice, thanks_for_sending]}, permanent, 5000, worker, [echo]},
           {mean, {echo, start, [mean, keep_your_fucking]}, permanent, 5000, worker, [echo]}]}}.

...

And you should then be able to do

$: make
erlc -Wf -o ebin/ src/*erl
cp src/*app ebin/
$: make start
[snip a whole bunch of startup notifications thanks to sasl]
(example@127.0.1.1)1> echo:echo(nice, candy).
{thanks_for_sending,candy}
(example@127.0.1.1)2> echo:echo(mean, garbage).
{keep_your_fucking,garbage}
(example@127.0.1.1)3>

Hacking a target process into your APIs isn't always necessary, but doing it lets you treat your API functions as faux-methods and Erlang processes as faux-objects[7].

Thus endeth the lesson. Next time, I'll put together some more authentication thoughts, and maybe build on this mini-tutorial to something actually useful.

---

Footnotes

1 - [back] - Which I just linked to despite the fact, because you should definitely use it if it works for you.

2 - [back] - If you specify processes and modules in your .app that don't actually get loaded by the supervisors, for example, it doesn't complain.

3 - [back] - Typically, this murder-suicide pact only happens when there's a serious, frequently triggered error in the code. In that situation, it's pointless to try to run the full program in any case.

4 - [back] - I do some decidedly non-standard things with dependencies and launching, which I can't honestly recommend except to the extent that they seem easiest from my perspective so far. You can take a look here, if you're curious.

5 - [back] - Don't use mine; believe it or not, it actually helps to build your own lightsaber. It may be a bit creaky, but at least you'll know how to fix it.

6 - [back] - The script I linked to automatically does other things too, like add readme files filled with minimal skeletons, generate a .gitignore file and start a git repository. All things I always do anyway, and would really prefer the computer to handle for me.

7 - [back] - That just happen to be backed by a truly fantastic concurrency model, and encouraged to act functionally.