[Common Lisp] Web フレームワークを作る

Common Lisp で Web フレームワークを作る、ってのに挫折すること幾年月。このごろはシンプルな方向でいってみようと思っている。最終的には実業務で使いたい。そうなると Weblocks も UCW も難しすぎる。ということでシンプルに。

まずは S 式を HTML にするマクロを作った。キーワードシンボルから始まるリストはタグに、@ で始まるシンボルはリクエストパラメータの参照にする。で Arc Challenge を書くと次のようになる。

(defun arc1 ()
  (html (:body
         (:form :action :arc2
                (:input :type :text :name :foo)
                (:input :type :submit)))))

(defun arc2 ()
  (html (:body (:a :href (format nil "arc3?foo=~a" @foo) "ここよ"))))

(defun arc3 ()
  (html (:body "you said: \"" @foo #\")))

まあ、シンプルじゃないかな。href のとこは何とかする必要があるけど。ソースは現状はパッケージ名と関数名を URL とする仕様で、Hunchentoot を使ってる。

(setf hunchentoot:*hunchentoot-default-external-format*
      (flexi-streams:make-external-format :utf-8)
      hunchentoot:*default-content-type* "text/html; charset=utf-8"
      hunchentoot:*show-lisp-errors-p* t
      hunchentoot:*show-lisp-backtraces-p* t)

(defvar *url-prefix* "/you/")
(defvar *port* 8888)

(defgeneric dispatch ()
  (:method ()
    (ppcre:register-groups-bind (package symbol-name)
        ((format nil "~a([^/]+)/([^?/]+)" *url-prefix*)
         (hunchentoot:request-uri))
      (with-output-to-string (*standard-output*)
        (funcall (symbol-function
                  (find-symbol (string-upcase symbol-name)
                               (intern (string-upcase package) :keyword))))))))

(defvar *dispatch*
  (hunchentoot:create-prefix-dispatcher *url-prefix* 'dispatch))

(pushnew *dispatch* hunchentoot:*dispatch-table*)

(defvar *server* (hunchentoot:start-server :port *port*))

;;;; ここからが html マクロ
(defmacro html (&body body)
  (let ((body (replace-html body)))
    `(progn
       ,@(mapcar #'to-html body))))

(defun replace-html (x)
  (cond ((and (symbolp x)
              (char= #\@ (char (symbol-name x) 0)))
         `(hunchentoot:parameter ,(string-downcase (subseq (symbol-name x) 1))))
        ((atom x)
         x)
        (t (cons (replace-html (car x))
                 (replace-html (cdr x))))))

(defun to-html (x)
  (if (or (atom x)
          (not (keywordp (car x))))
      `(princ (>html ,x))
      (to-keyword-html x)))

(defun to-keyword-html (x)
  (let ((tag (>html (car x))))
    (multiple-value-bind (attrs body) (split-attrs-body (cdr x))
      `(progn
         (princ "<")
         (princ ,tag)
         ,@(mapcar
            {`(format t " ~a=\"~a\"" ,(>html (car _)) (>html ,(cdr _)))}
            attrs)
         ,@(if body
               `((princ ">")
                 ,@(mapcar {`(html ,_)} body)
                 (princ "</")
                 (princ ,tag)
                 (princ ">"))
               `((princ "/>")))))))

(defun >html (x)
  (cond ((null x) "")
        ((symbolp x) (string-downcase (symbol-name x)))
        (t (princ-to-string x))))

(defun split-attrs-body (arg)
  (let (attrs body)
    (labels ((f (x)
               (cond ((null x)
                      nil)
                     ((atom x)
                      (setf body (list x)))
                     ((keywordp (car x))
                      (push (cons (car x) (cadr x)) attrs)
                      (f (cddr x)))
                     (t
                      (setf body x)))))
      (f arg)
      (values (reverse attrs) body))))

この html マクロを書くのにずいぶん時間がかかってしまった。もっと美しく書けるような気がする。Common Lisp を使ってるときって、他のどの言語を使っているときよりも、自分の頭の悪さを実感するんだよね。それだからこそ、ささいなコードでも Common Lisp で書くのは楽しい。