(blog ‘lucindo)

Para testar algumas coisas refiz hoje o código do post Common Lisp e Ajax. Desta vez estou usando o patch para o HT-AJAX com suporte e jQuery. Além disso, para gerar código JavaScript uso Parenscript. Assim todo HTML e JS é produzido por s-exps:

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *dependencies*
    ‘(:asdf :hunchentoot :ht-ajax :cl-who :parenscript))
  (map nil ‘require *dependencies*))

(defpackage :ajax-test
  (:use :common-lisp :hunchentoot :ht-ajax :cl-who :parenscript))

(in-package :ajax-test)

(defparameter *local-dir* “/Users/lucindo/Documents/Lisp/web/3rdparty/”)
(defparameter *ajax-handler-url* “/ajax”)
(defparameter *ajax-processor*
  (make-ajax-processor :type :jquery
                       :server-uri *ajax-handler-url*
                       :js-file-uris “/static/jquery.js”))

(defun testfunc (command)
  (prin1-to-string (handler-case (eval (read-from-string command nil))
                                 (error (c) (format nil “~a” c)))))

(defun js ()
  (ps
   (defun command_clicked ()
     (let ((command (document.get-element-by-id “command”)))
       (with-slots (value) command
                   (ajax_testfunc_set_element “result” value))))))

(defun main-page ()
  (with-html-output-to-string
   (*standard-output* nil :prologue t)
   (:html
    (:head
     (:script :type “text/javascript” :src “/js”)
     (:title “AJAX test”)
     (fmt “~a” (generate-prologue *ajax-processor*)))
    (:body
     (:h1 “ajax test”)
     (:table :width “50%”
             (:tr
              (:td :colspan “2″
                   (:span :id “result”
                          (:i “no results yet”))))
             (:tr
              (:td :width “70%”
                   (:input :type “text”
                           :size “70″
                           :name “command”
                           :id “command”))
              (:td (:input :type “button”
                           :value “eval”
                           :onclick (ps-inline (command_clicked))))))))))

(eval-when (:load-toplevel :execute)
  (export-func *ajax-processor* ‘testfunc :method :post)
  (setf *dispatch-table*
        (list ‘dispatch-easy-handlers
              (create-folder-dispatcher-and-handler “/static/”
                                                    *local-dir* “text/plain”)
              (create-prefix-dispatcher *ajax-handler-url*
                                        (get-handler *ajax-processor*))
              (create-prefix-dispatcher “/js” ‘js)
              (create-prefix-dispatcher “/” ‘main-page))))

(defparameter *webserver* nil)

(defun start-web (&optional (port 4242))
  (setf *webserver* (start-server :port port)))

(defun stop-web ()
  (stop-server *webserver*))

Download: ajax2.lisp

Só porque esse blog está muito parado:

Eight years to do TeX? How smart can he be? He should have used Lisp.

Kenny Tilton, sobre Donald Knuth

HT-AJAX (documentação aqui) é uma extenção do Hunchentoot que permite exportar suas funções lisp de modo que elas podem ser acessadas via JavaScript, usando AJAX. Um pequeno exemplo de uso dessa biblioteca está nesse post.

HT-AJAX suporta vários AJAX processors, como Prototype e Dojo, mas não jQuery. Então fiz um pequeno patch adicionando suporte a jQuery.

Download: ht-ajax_0.0.7-jquery.patch

Aplicando o patch (SBCL):

$ cd ~/.sbcl/site/ht-ajax_0.0.7
$ wget http://lucindo.com.br/lisp/ht-ajax_0.0.7-jquery.patch
$ cat ht-ajax_0.0.7-jquery.patch | patch -p0
$ sbcl
* (require :asdf)
* (asdf:oos 'asdf:compile-op :ht-ajax)

Two options for lispers:

• Purely functional Lisps (subset of CL or something like Clojure, LFE, etc)
• Cells!!!

Bom, esse post é mais um snippet de como implementar um serviço REST usando Hunchentoot. Dessa vez adicionei suporte a ETags no código do outro post. Ficou assim o tratamendo das requisições:

(defvar *data-id* “e8d8993494ffc11:b8e”)
(defun get-data-id (target)
  “get the last id for requested data”
  *data-id*)

(defmethod handle :around (request-method)
  “ETag support for all methods”
  (let ((data-id (get-data-id (script-name)))
        (last-id (header-in :If-None-Match)))
    (setf (header-out :ETag) data-id)
    (if (and last-id (equalp last-id data-id))
        (setf (return-code) +http-not-modified+)
        (call-next-method))))

Fazendo um request normal:

GET /rest HTTP/1.1
Host: eddie

HTTP/1.1 200 OK
Content-Length: 3
Content-Type: text/html; charset=iso-8859-1
Date: Sun, 27 Apr 2008 20:07:53 GMT
Server: Hunchentoot 0.15.6
Etag: e8d8993494ffc11:b8e

GET

Agora o cliente passando o ETag:

GET /rest HTTP/1.1
Host: eddie
If-None-Match: e8d8993494ffc11:b8e

HTTP/1.1 304 Not Modified

Suportar ETags é muito fácil e se o cliente do seu serviço souber usar é muito útil para os dois.

Download: rest.lisp

Um snippet de teste que eu fiz para um serviço REST usando Hunchentoot.

Usando função genérica é possível fazer um “pattern matching” e a implementação fica parecida com Erlang/YAWS (a vir no BedDB).

(eval-when (:load-toplevel :compile-toplevel :execute)
  (require ‘hunchentoot))

(defpackage :ht-rest
  (:use :common-lisp :hunchentoot))

(in-package :ht-rest)

(defun add-dispatcher (dispatcher-fn)
  “Helper function to add dispatcher functions to dispatch table”
  (nconc *dispatch-table* (list dispatcher-fn)))

(defun create-dispatcher (url-prefix handler &key (regexp nil))
  “Creates a dispatcher and add it to dispatch table given the
url prefix and handler function. The url prefix can be a regular
expression (in this case set the :regexp keyword).”
  (let ((dispatcher-fn
         (funcall
          (if regexp ‘create-regexex-dispatcher ‘create-prefix-dispatcher)
          url-prefix handler)))
    (add-dispatcher dispatcher-fn)))

(defun handle-rest ()
  “Simply delegate to appropriate handler”
  (handle (request-method)))

(defgeneric handle (request-method)
  (:documentation “Generic REST handler”))

(defmethod handle :before (request-method)
  (log-message :info “REST in: [method ~a] [target ~a] [qs ~s]”
               (request-method) (script-name) (query-string)))

(defmethod handle :after (request-method)
  (log-message :info “REST out: [code ~a] [method ~a] [target ~a] [qs ~s]”
               (return-code) (request-method)
               (script-name) (query-string)))

(defmethod handle ((request-method (eql :get)))
  (string (request-method)))

(defmethod handle ((request-method (eql :post)))
  (string (request-method)))

(defmethod handle ((request-method (eql :put)))
  (string (request-method)))

(defmethod handle ((request-method (eql :delete)))
  (string (request-method)))

(defmethod handle (request-method)
  (setf (return-code) +http-method-not-allowed+))

(defvar *ht-server* nil)

(defun setup ()
  (create-dispatcher “/rest” ‘handle-rest))

(defun start (&optional (setup-p t))
  (prog1
      (setq  *show-lisp-errors-p* t
             *show-lisp-backtraces-p* t
             *dispatch-table* (list ‘dispatch-easy-handlers)
             *ht-server* (start-server :port 8080))
    (when setup-p (setup))))

(defun stop ()
  (stop-server *ht-server*))

(defun re-start ()
  (progn
    (stop)
    (start nil)))

Passo a passo para instalar e configurar Erlang, SBCL e Emacs no Leopard.

Primeiro instale o xcode que vem no CD do Leopard. Em seguida instale o MacPorts.

O MacPorts está com versões bem atualizadas de Erlang (R12B-0) e SBCL (1.0.13):
$ sudo port selfupdate
$ sudo port install erlang +smp +ssl
$ sudo port install sbcl +threads
$ sudo port clean --all installed


O MacPorts instala tudo no /opt, então coloque o seguinte no seu .profile:
export PATH=/opt/local/bin:/opt/local/sbin:$PATH


Para emacs existem algumas opções. Eu uso o Carbon Emacs (que já vem com slime). Depois de instalar adicione o seguinte no seu .emacs:

(add-to-list 'exec-path “/opt/local/bin”)
(add-to-list ‘load-path “/opt/local/lib/erlang/lib/tools-2.6/emacs”)

(setq erlang-root-dir “/opt/local”)
(require ‘erlang-start)

(require ‘slime)
(setq inferior-lisp-program “sbcl –noinform”)
(add-hook ‘lisp-mode-hook (lambda () (slime-mode t)))
(add-hook ‘inferior-lisp-mode-hook (lambda () (inferior-slime-mode t)))

Update: Para passar parâmetros para a Erlang VM use o seguinte no seu .emacs:

(setq inferior-erlang-machine-options
      '(“-pa” “/opt/local/lib/yaws/ebin”
        “-sname” “mini”))

Para quem ainda não sabe, o Netflix Prize é uma competição que começou no final do 2006 cujo objetivo é melhorar em 10% o algoritmo de sugestão de filmes da Netflix. Quem conseguir fazer isso recebe o prêmio de U$ 1.000.000.

Bom, fiz um pequeno código esses dias que joga os dados do Netflix Prize no Postgres para depois poder brincar um pouco com isso e quem sabe ganhar uma graninha

Usei basicamente o Postmodern e a nova versão do Postmodern-utils. Ainda preciso fazer uma página com a documentação do pacote. Nessa versão entraram algumas funções novas: set-connection-spec, create-tables, map-dao e for-each-dao.

Seguindo a sugestão do Leonardo Varuzza, agora o Postmodern-utils poder ser instalado assim:

* (asdf-install:install :postmodern-utils)

Vamos ao código. Primeiro a definição do pacote:

(eval-when (:load-toplevel :compile-toplevel :execute)
  (require :postmodern)
  (require :postmodern-utils)
  (require :cl-fad)
  (require :split-sequence))

(defpackage :netflix
  (:use :common-lisp :postmodern :postmodern-utils)
  (:export #:setup-database
           #:load-data
           #:predict-ratings
           #:movies #:id-of #:year-of #:title-of #:get-movie
           #:ratings #:user-of #:movie-of #:rating-of #:date-of
           #:get-ratings-of-user #:get-ratings-of-movie))

(in-package :netflix)

Agora alguns dados globais (mude o parametro *netflix-data-dir*):

(defparameter *netflix-data-dir* “/path/to/netflix/download”)
(defparameter *movies-file*
  (concatenate ’string *netflix-data-dir* “/movie_titles.txt”))
(defparameter *ratings-dir*
  (concatenate ’string *netflix-data-dir* “/training_set/”))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (set-connection-spec :username “netflix”
                       :password “”
                       :database “netflix”
                       :hostname “localhost”))

Agora a definição da tabela movies e funções para criar e acessar daos desse tipo:

(deftable movies ()
  ((movie-id :type integer
             :accessor id-of
             :initarg :movie-id)
   (year :type string ;; may be “NULL”
         :accessor year-of
         :initarg :year)
   (title :type string
          :accessor title-of
          :initarg :title))
  (:indices movie-id)
  (:class-name movies))

(defun make-movie (movie-id year title)
  (with-pooled-connection
      (save-dao (make-instance ‘movies
                               :movie-id movie-id
                               :year year
                               :title title))))

(defun get-movie (movie-id)
  (with-pooled-connection
      (get-dao ‘movies movie-id)))

Para ler e parsear os arquivos vamos usar a seguinte função auxiliar:

(defun process-file-by-line (file-name fn)
  (with-open-file (stream file-name :external-format :iso-8859-1)
    (do ((line (read-line stream nil)
               (read-line stream nil)))
        ((null line))
      (funcall fn line))))

Com ela podemos parsear o arquivo movie_titles.txt assim:

(defun load-movies (movies-file)
  (process-file-by-line
   movies-file
   #’(lambda (line)
       (let* ((splitted-line (split-sequence:split-sequence #\, line))
              (movie-id (parse-integer (first splitted-line)))
              (year (second splitted-line))
              (title (third splitted-line)))
         (make-movie movie-id year title)))))

Depois definimos a tabela ratings e uma função para criar os daos desse tipo:

(deftable ratings ()
  ((user-id :type integer
            :accessor user-of
            :initarg :user-id)
   (movie-id :type integer
             :accessor movie-of
             :initarg :movie-id)
   (rating :type integer
           :accessor rating-of
           :initarg :rating)
   (date :type string
         :accessor date-of
         :initarg :date))
  (:indices (user-id movie-id) rating)
  (:class-name ratings))

(defun make-rating (user-id movie-id rating date)
  (with-pooled-connection
      (save-dao (make-instance ‘ratings
                               :user-id user-id
                               :movie-id movie-id
                               :rating rating
                               :date date))))

Podemos fazer algumas funções para selecionar listas de ratings, como por exemplo:

(defun get-ratings-of-user (user-id)
  (with-pooled-connection
    (select-daos ‘ratings :test `(:= user-id ,user-id))))

(defun get-ratings-of-movie (movie-id)
  (with-pooled-connection
    (select-daos ‘ratings :test `(:= movie-id ,movie-id))))

O parse dos arquivos com ratings é feito pelas seguintes funções:

(defun load-ratings-file (file)
  (let ((movie-id 0))
    (process-file-by-line
     file
     #’(lambda (line)
         (if (search “:” line)
             (setq movie-id (parse-integer line :junk-allowed t))
             (let* ((splitted-line (split-sequence:split-sequence #\, line))
                    (user-id (parse-integer (first splitted-line)))
                    (rating (parse-integer (second splitted-line)))
                    (date (third splitted-line)))
               (make-rating user-id movie-id rating date)))))
    (format t “processed: ~a~%” file)))

(defun load-ratings (ratings-dir)
  (cl-fad:walk-directory
   ratings-dir
   #’(lambda (file)
       (load-ratings-file file))))

Agora as funções para carregar todos os dados no Postgres:

(defun load-data ()
  (load-movies *movies-file*)
  (load-ratings *ratings-dir*))

(defun setup-database (&optional (first-drop nil))
  (with-pooled-connection
    (create-tables ‘(movies ratings) :first-drop first-drop)))

Por fim a função para processar os arquivos de entradas e gerar o arquivo com as previsões dada uma função de previsão que recebe três parêmetros: id do usuário, id do filme e a data da votação.

(defun predict-ratings (query-file predict-file predict-fn)
  (with-open-file (stream predict-file :direction :output)
    (let ((movie-id 0))
      (process-file-by-line
       query-file
       #’(lambda (line)
           (if (search “:” line)
               (progn
                 (setq movie-id (parse-integer line :junk-allowed t))
                 (format stream “~a:~%” movie-id))
               (let* ((splitted-line (split-sequence:split-sequence #\, line))
                      (user-id (parse-integer (first splitted-line)))
                      (date (second splitted-line)))
                 (format stream “~1$~%”
                         (funcall predict-fn user-id movie-id date)))))))))

Agora tenho todos os dados e funções para fazer a manipulação. Só falta a função de 1 milhão de dólares e rodar:

(predict-ratings “qualifying.txt” “winner.txt” #’million-dollar-function)

Download: netflix.lisp

Observação 1: carregar todos os dados no Postgres dessa maneira demora (poucos dias), pois faço um insert para cada rating, e são 100 milhões deles.

Observação 2: vale a pena ver também o excelente post do Juho Snellman sobre como processar os dados do Netflix Prize usando Common Lisp.

A submissão campeã do prêmio Best of show do IOCCC de 1989 foi o seguinte interpretador Lisp (aqui modificado para compilar no gcc de hoje):

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#define p char*
#define P ,(p)
#define T(E) !strcmp(E,“()”)
#define U return
#define W while
#define X sbrk(199)
#define z atof
#define e isspace
#define D A(_)
#define E S(C(_))
#define B(y) p y(_)p _;{
#define G(y,V) B(y)p i;U sprintf(i=X,“%lf”,z(E)V z(S(C(D)))),i;}

        p sbrk(),*S(),*j(),*O,*H;K,Y,M=14;double
      z();Q(_)p _;{int V=0;W(e(*_))_++;H=_;W(V|!(e
    (*H)|*H==‘)’||(*H==‘(’&&H-_)))V+=(*H==‘(’)-(*H==
      ‘)’),H++;U H-_;}B(C)U _++,Y=Q(_),_=strncpy(X,_,Y),_[
    Y]=0,_;}B(A)_++,_+=Q(_);W(e(*_))_++;U O=X,*O=‘(’,strcpy(
  O+1,_),O;}B(Z)U _;}B(c)U C(E);}B(q)U A(E);}B(t)p i=E;U H=S(C
(D)),sprintf(O=X,T(H                 )?“(%s)”:“(%s %s”,i,H+1)

         ,O;}B(F)U S(C(A(T(E)?D:_)));}L(i,s)p

i,*s;{U isdigit(*i)     ?         z(i)!=z(s):strcmp(i,s);}
  B(b)U L(E,S(C(D)))?“()”:“t”;}B(R)U E;}B(o)U z(E)<z(S(C(D)))?
    “t”:“()”;}G(f,+)G(g,-)G(h,*)p r[4][2]={“function”   P R,
      “quote”P C,“lambda”P Z,“defun”P j};B(j)U r[M][1]=D,*
    r[M++]=C(_);}p not[99][2]={“if”P F,“equal”P b,“<”
      P o,“+”P f,“-”P g,“*”P h,“car”P c,“cdr”P q,
        “cons”P t,“t”,“t”};B(S)int Li,s;p u;if(
          isdigit(*_)|T(_))U _;for(Y=M;Y–;)
        if(!strcmp(_,*r[Y]))U r[Y][1]
          ;u=E,_=D;if(*u-‘(’)U(*((p(*)())u)
        )(_);s=Li=M;W(!T(_))r[M][1]=E,*r[M++]
    =“”,_=D;O=C(u);W(!T(O))*r[Li++]=C(O),O=A(O);U O=S
    (C(A(u))),M=s,O;}main(){H=O=X,Y=0;W(Y|!e(K=getchar()))K==
    EOF?exit(0):0,Y+=(K==‘(’)-(K==‘)’),*H++=K;*H=0,puts(S(O))
                ,
        main();{printf(“XLISP 4.0n”);}}

Essa implementação foi feita por Jari Arkko, Ora Lassila e Esko Nuutila da Universidade Tecnológica de Helsinki. Ele implementa as operações:

+	-	*	<	()
car	cdr	cons	defun	equal
function if	lambda	quote	t

Os autores propõe o seguinte teste:

(+ 2.5 3.1)
(defun fib (n)
  (if (< n 2)
      1
      (+ (fib (- n 2)) (fib (- n 1)))))
(fib 10)
(defun ! (x) (if (equal x 0) 1 (* x (! (- x 1)))))
(! 7)
(defun fn1 (fn) (+ (fn 1 2) (fn 3 4)))
(defun fn2 (a b) (+ a b))
(fn1 (function +))
(fn1 (function fn2))
(fn1 (function (lambda (z1 z2) (+ z1 z2))))
(quote a)
(cons (quote (a b)) (quote (c d e)))
(cons (quote (f)) ())
(car (quote (a b c)))
(cdr (cdr (quote (g h i))))

Mais informações aqui.

Download: jar.2.c (versão alterada para gcc 4.x)

Eu precisava de uma wiki para ajudar a organizar idéias de um projeto. Depois de conversar com os outros envolvidos eu fiquei de instalar uma em um servidor para começarmos a usar no dia seguinte.
Resolvi que seria uma experiência interessante escrever uma wiki em CL. Como precisávamos da wiki para o dia seguinte eu tinha que escrever tudo em uma noite, e se não desse certo eu instalaria uma wiki qualquer.
Bom, foi aí que surgiu a Milki, que estamos usando até hoje. As bibliotecas que eu usei:

• Hunchentoot: web sever/container
• CL-WHO: para escrever HTML em sexps
• CL-Store: serialização de objetos
• CL-Fad: manipulação de arquivos e diretórios
• S-Utils: para formação de datas

Todas elas podem ser instaladas via ASDF-Install.

Para a formatação usei a sintaxe Markdown. A renderização é feita via JavaScript, com o pacote Showdown.

Vou tentar colocar algumas partes do código explicando como tudo foi implementado. No final desse post tem alguns links com o código-fonte completo.

Começamos carregando todas as dependências e definindo o pacote:

;;; MILKI - MInimal Lisp wiKI
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :hunchentoot)
  (require :cl-who)
  (require :cl-store)
  (require :s-utils)
  (require :cl-fad))

(defpackage :milki
  (:use :common-lisp :cl-who)
  (:export #:start-wiki #:stop-wiki
           #:add-user #:change-password #:remove-user))

(in-package :milki)

As funções para iniciar e terminar a execução do servidor web são wrappers para funções do Hunchentoot:

; we need a variable to hold the server instance
(defvar *wiki-server* nil “the hunchentoot server instance”)

(defun start-wiki (&key (port 8080))
  (setf *wiki-server* (hunchentoot:start-server :port port)))

(defun stop-wiki ()
  (hunchentoot:stop-server *wiki-server*))

Milki usa três diretórios separados: um para os arquivos estáticos (CSS, JavaScript, etc), um para os arquivos recebidos via upload e um outro para armazenar os dados das páginas. Nesses dois últimos é necessário ter permissão de escrita:

(defparameter *static-files-dir* “/home/lucindo/milki/static/”
  “place where we can put all JavaScript and CSS files”)
(defparameter *data-storage-dir* “/home/lucindo/milki/data/”
  “place where we’ll store all data”)
(defparameter *upload-dir* “/home/lucindo/milki/files/”
  “place to put uploaded files”)

Como esse sistema vai rodar num ambiente multi-threaded usei um lock global que será aplicado ao acesso de arquivos e estruturas.

;; this will run on a multithreaded environment and for
;; some operations we will use a global lock
(defvar *lock* (hunchentoot-mp:make-lock “milki-lock”))

(defmacro locked (&body body)
  `(hunchentoot-mp:with-lock (*lock*) ,@body))

Agora temos a implementação do controle usuários. Apenas a autenticação é acessada pelo Hunchentoot, ou seja, a criação, remoção e mudança de senha não são feitas online, e sim avaliando as expressões correspondentes na imagem lisp (por isso essas funções são exportadas no pacote).

;; we need users
;; users are stored in a assoc-list: (”username” password)
;; the password is a md5 of password string
;; here we use the md5 package (required by hunchentoot)
;; the users list is stored in a file using cl-store
(defun users-file ()
  (concatenate ’string *data-storage-dir* “.users”))

; will be nil at first run
(defvar *user-alist* (ignore-errors (cl-store:restore (users-file))))

(defun sync-users-file ()
  (locked
    (cl-store:store *user-alist* (users-file))))

(defun add-user (user pass)
  (push (cons user (md5:md5sum-sequence pass)) *user-alist*)
  (sync-users-file))

(defun remove-user (user)
  (setf *user-alist*
        (remove-if #’(lambda (up-pair)
                       (string= user (car up-pair))) *user-alist*))
  (sync-users-file))

(defun user-pass-match-p (user pass)
  (and user pass
       (equalp (cdr (assoc user *user-alist* :test #’string=))
               (md5:md5sum-sequence pass))))

(defun change-password (user oldpass newpass)
  (when (and (user-pass-match-p user oldpass) newpass)
    (setf (cdr (assoc user *user-alist* :test #’string=))
          (md5:md5sum-sequence newpass))
    (sync-users-file)))

Essa wiki é privada. Só é possível acessá-la tendo um usuário. Assim todas as páginas precisam de controle de acesso, e para isso usamos macros:

; require a digest autorization
(defmacro with-authorization (&body body)
  (let ((user (gensym))
        (pass (gensym)))
    `(multiple-value-bind (,user ,pass)
         (hunchentoot:authorization)
       (if (user-pass-match-p ,user ,pass)
           ,@body
           (hunchentoot:require-authorization “[milki login]”)))))

; all wiki pages requires authorization (this is a private wiki!)
(defmacro with-wiki-page-body (&body body)
  `(with-authorization
     (with-html-output-to-string (*standard-output* nil :prologue t)
       (:html
        (:head
         (:title “milki - a very simple wiki”)
         (:script :type “text/javascript” :src “/static/showdown.js”)
         (:script :type “text/javascript” :src “/static/milki.js”)
         (:link :rel “stylesheet” :href “/static/milki.css” :type “text/css”))
        (:body ,@body)))))

Agora, cada página é armazenada como uma lista de instancias do objeto wiki-post. Sempre que uma página é alterada criamos uma instância desse objeto e adicionamos à lista. Assim mandemos o histórico. Cada item da lista é uma versão da página, sendo que o primeiro deles é a versão mais atual.

;; we’ll store wiki posts in files
(defun wiki-post-file-name (post-name)
  (concatenate ’string *data-storage-dir* “wiki-” (hunchentoot:url-encode post-name)))

(defun sync-wiki-post (post-name wiki-post-list)
  (locked
    (cl-store:store wiki-post-list (wiki-post-file-name post-name))))

; may return nil
(defun get-wiki-post (post-name)
  (locked
    (ignore-errors (cl-store:restore (wiki-post-file-name post-name)))))

;; a wiki post is very simple
(defclass wiki-post ()
  ((contents :initarg :contents
             :accessor post-contents)
   (timestamp :initform (get-universal-time)
              :accessor post-timestamp)
   (user :initarg :user
         :accessor post-user)))

(defun add-wiki-post (post-name contents user)
  (let ((new-post (make-instance ‘wiki-post :contents contents :user user))
        (post-list (get-wiki-post post-name)))
    (if post-list
        (push new-post post-list)
        (setf post-list (list new-post)))
    (sync-wiki-post post-name post-list)))

A seguir definimos as funções principais da wiki: a que imprime uma página, a de edição de páginas e o handler principal. Como a renderização é feita via JavaScript não existe preview da edição, pois o mesmo é feito online, conforme o usuário edita:

(defun show-wiki-post (post-name post-version post)
  (let ((edit-link (conc post-name “?edit=true&version=” (princ-to-string post-version))))
    (with-wiki-page-body
      (:div :align “right”
            (:font :size “-1″
                   (:a :href (str edit-link) “edit”)))
      (:div :id “wiki-post” :class “wiki-post”
            :ondblclick (conc “document.location=”" edit-link “”;”)
            (str (post-contents post)))
      (:hr :class “footer”)
      (:span :id “footer” :class “footer”
             (:font :size “-1″
                    (:table :border “0″
                            :width “98%”
                            :align “center”
                            :cellpadding “0″
                            :cellspacing “0″
                            (:tr
                             (:td :align “left”
                                  “useful links: “
                                  (:a :href “/” “start page”)
                                  ” - “
                                  (:a :href “/index” “wiki index”))
                             (:td :align “right”
                                  (str (conc “last updated by “
                                             (post-user post)
                                             ” on “
                                             (s-utils:format-universal-time
                                              (post-timestamp post))))))))))))

(defun print-wiki-post (post-name post-version)
  (let* ((wiki-post-list (get-wiki-post post-name))
         (the-post (nth post-version wiki-post-list)))
    (cond ((not wiki-post-list)
           (with-wiki-page-body (:center (:h2 “Hey! I’m an empty page!”)
                                         (:a :href (conc post-name “?edit=true”)
                                             (:h3 “edit me”)))))
          ((not the-post) (show-wiki-post post-name post-version (car wiki-post-list)))
          (t (show-wiki-post post-name post-version the-post)))))

(defun edit-wiki-post (post-name post-version)
  (let* ((wiki-post-list (get-wiki-post post-name))
         (the-post (nth post-version wiki-post-list)))
    (with-wiki-page-body
      (:center
       (:h2 (str (conc “editing: “ post-name)))
       (:div :align “right”
             (:font :size “-1″
                    (:a :href “/upload” “click here to upload files”)
                    (:br)
                    “use markdown syntax: cheatsheet “
                    (:a :href “javascript: open_markdown_cheatsheet()” “here”)))
       (:form :method :post :action (str post-name)
              (:table :with “98%” :border “0″ :cellpadding “10″ :cellspacing “2″
                      (:tr
                       (:td :width “48%” :valign “top”
                            (:textarea :id “wiki-input”
                                       :name “contents” :cols 60 :rows 20 :style “width: 100%;”
                                       (when the-post (str (post-contents the-post)))))
                       (:td :width “48%” :valign “top” :style “border-left: solid 1px #736F6E”
                            (:div :id “wiki-preview”)))
                      (:tr :rowspan “2″
                           (:td
                                (:input :type :submit :value “save”)
                                (str ” or “)
                                (:a :href (princ-to-string post-name) “cancel”))))))
       (when  wiki-post-list
         (htm
          (:p “version history:”)
          (:ul
           (loop for i from 0
              for wiki-post in wiki-post-list
              do (htm (:li (fmt “version ~a by ~a: “ i (post-user wiki-post))
                           (:a :href (conc post-name “?version=” (princ-to-string i))
                               (str (conc (s-utils:format-duration
                                           (- (get-universal-time)
                                              (post-timestamp wiki-post)))
                                          ” ago”))))))))))))

;; the main function handler
(defun milki ()
  (hunchentoot:no-cache)
  (let ((post-name (hunchentoot:script-name))
        (post-version (hunchentoot:get-parameter “version”))
        (edit-p (hunchentoot:get-parameter “edit”))
        (contents (hunchentoot:post-parameter “contents”)))
    (if post-version
        (setq post-version (parse-integer post-version))
        (setq post-version 0))
    (when contents
      (add-wiki-post post-name contents (hunchentoot:authorization)))
    (if edit-p
        (edit-wiki-post post-name post-version)
        (print-wiki-post post-name post-version))))

Além de poder criar e editar páginas, deveríamos poder fazer upload de arquivos. O seguinte handler adiciona essa funcionalidade:

; file-upload handler
(defun milki-upload ()
  (let ((sent-file (hunchentoot:post-parameter “file”))
        (remove-file (hunchentoot:get-parameter “remove”)))
    (when remove-file
      (ignore-errors (delete-file
                      (cl-fad:pathname-as-file
                       (concatenate ’string *upload-dir* remove-file))))
      (hunchentoot:redirect (hunchentoot:script-name)))
    (when (and sent-file (listp sent-file))
      (let ((path (car sent-file))
            (file-name (cadr sent-file)))
        ;; strip directory info sent by Windows browsers
        (when (search “Windows” (hunchentoot:user-agent) :test #’char-equal)
          (setq file-name (cl-ppcre:regex-replace “.*\\” file-name “”)))
        (let ((new-path (concatenate ’string *upload-dir* file-name)))
          (rename-file path (ensure-directories-exist new-path))))))
  (hunchentoot:no-cache)
  (let ((file-list (cl-fad:list-directory *upload-dir*)))
    (with-wiki-page-body
      (:center
       (:h2 “file uploader”)
       (:form :method :post :enctype “multipart/form-data”
              (:input :type :file :name “file”)
              (:input :type :submit :value “upload”))
       (when file-list
         (htm
          (:table :border “1″ :width “95%”
                  (dolist (file file-list)
                    (let ((file-link-name
                           (hunchentoot:url-encode
                            (cl-ppcre:regex-replace “.*/” (princ-to-string file) “”))))
                      (htm (:tr
                            (:td (:a :href
                                     (conc “/static/files/” file-link-name)
                                     (str file-link-name)))
                            (:td (str (conc “/static/files/” file-link-name)))
                            (:td (:a :href
                                     (conc (hunchentoot:script-name)
                                           “?remove=”
                                           file-link-name) “remove”)))))))))

Uma outra funcionalidade necessária é o índice, que lista todas as páginas já criadas (mesmo as que não conseguimos acessar pela estrutura de links):

;; milki page index
(defun generate-wiki-index ()
  (let ((wiki-pages-list ())
        (wiki-files (cl-fad:list-directory *data-storage-dir*)))
    (dolist (file-path wiki-files)
      (let ((file-name (cl-ppcre:regex-replace “.*/” (princ-to-string file-path) “”)))
        (when (string= (subseq file-name 0 5) “wiki-”)
          (push (hunchentoot:url-decode (subseq file-name 5)) wiki-pages-list))))
    (sort wiki-pages-list #’string<)))

; index handler
(defun milki-index ()
  (let ((wiki-pages (generate-wiki-index)))
    (with-wiki-page-body
      (:center (:h2 “wiki index”)
               (:h4 (fmt “~a pages so far…” (length wiki-pages))))
      (:ul
       (dolist (page wiki-pages)
         (htm (:li (:a :href page (str page)))))))))

Por fim, precisamos associar as funcões e diretórios às urls:

;; finally we setup hunchentoot environment
(eval-when (:execute :load-toplevel)
  (setf hunchentoot:*show-lisp-errors-p* t
        hunchentoot:*show-lisp-backtraces-p* t
        hunchentoot:*dispatch-table*
        (list ‘hunchentoot:dispatch-easy-handlers
              (hunchentoot:create-folder-dispatcher-and-handler
               “/static/files/” *upload-dir*)
              (hunchentoot:create-folder-dispatcher-and-handler
               “/static/” *static-files-dir*)
              (hunchentoot:create-prefix-dispatcher “/upload” ‘milki-upload)
              (hunchentoot:create-prefix-dispatcher “/index” ‘milki-index)
              (hunchentoot:create-prefix-dispatcher “/” ‘milki))))

E é isso. Uma wiki bem simples, feita para poucos usuários. Estou usando há quase um mês e até agora parece que funciona. Uma coisa que eu não vi em outras wikis (mas também não procurei muito) é a funcionalidade de preview online, que ajuda muito na hora de editar. Quem quiser o código completo é só seguir os links abaixo.

Download: milki.lisp
Arquivos que ficam no diretório de arquivos estáticos:

• milki.css: CSS da wiki
• showdown.js: pacote para renderizar markdown
• milki.js: chamadas para o showdown.js
• markdown.html: ajuda da sintaxe markdown