2009/05/05

GW のまとめ

3日

合同お祝い会。誕生日3人にこどもの日。

4日

Dvorak 配列での l の位置は絶対に失敗だと思うから l と ; の位置を入れ替えた。まだ慣れない。

Chaton Gauche が楽しそうで、自分でもちょこっと作ってみた。

5日

ラ・フォル・ジュルネ にうちの家族とKM氏で行ってきた。バッハです。なんて楽しげにバイオリンを弾くんだろう。

KO氏は綺麗で大人になった感じがした。

その他の日

仕事。リスク管理できてないよね。

;;;;-*- coding: utf-8 -*-
(in-package :you.example.chat)

(defvar *js*
(hunchentoot:create-folder-dispatcher-and-handler
"/js/" (merge-pathnames "js/" (directory-namestring *load-truename*))))

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

(defmacro with-default-template ((&key (title "チャット")) &body body)
`(html (:html
(:head
(:script :type "text/javascript" :src "/js/jquery-1.3.2.js")
(:link :rel "stylesheet" :href "default.css" :type "text/css")
(:title ,title))
(:body
(:div :id :main
,@body)
(:div :id :footer "Powered by Common Lisp")))))

(defaction default.css ()
(setf (hunchentoot:content-type*) "text/css")
(html "
.name {
font-size: 0.8em;
}
.say-ts {
float: right;
align: right;
color: gray;
font-size: 0.7em;
}
.content {
margin-bottom: 0.3em;
}
#list {
width: 80%;
height: 10em;
overflow: auto;
}
#footer {
text-align: right;
font-size: 0.6em;
}
"
))


(defvar *loop-process* nil)

(defaction index.html ()
(unless *loop-process*
(setf *loop-process* (spawn (loop-process))))
(with-default-template ()
(:h1 "チャット")
(:div :id :list)
(:form :onsubmit (ps (return (say)))
(:div (:textarea :id :content :rows 3 :cols 50))
(:div (:submit :value "話す")
" 名前:" (:text :id :name :value "かめ")))
(:script
(ps (defun say ()
($.post "say" (create :content ((@ ($ "#content") val))
:name ((@ ($ "#name") val)))
(lambda (data)
((@
((@ ($ "#content") val) "")
focus))))
(return false))
(defun refresh ()
(let ((id ((@ ($ "#list div.entry:last") attr) "id")))
($.post "refresh" (create :id (if id id ""))
(lambda (data)
(if (!= data "")
((@ ((@ ($ "#list") append) data)
scroll-top) 99999))
(set-timeout refresh 100)))))
((@ ($ "#content") keyup) (lambda (e)
(if (= e.key-code 13)
(say))))
($(refresh))))))

(defun generate-id ()
(format nil "~s~a" (get-universal-time) (gensym)))

(defun loop-process ()
(loop for data = (process-receive)
with wait = nil
do (if (eq data :say)
(progn (mapc (lambda (x)
(process-send x t))
wait)
(setf wait nil))
(push data wait))))

(defaction say ()
(unless (or (q:emptyp @name) (q:emptyp @content))
(execute-sql #q(insert into chat(id, name, content, say_ts)
values(:id, :name, :content, current_timestamp))
:id (generate-id)
:name @name
:content @content))
(process-send *loop-process* :say))

(defaction refresh ()
(do-query (#q(select count(*) as count from chat where id > :id)
:id @id)
(when (zerop $count)
(process-send *loop-process* *current-thread*)
(process-receive :timeout 30)))
(html
(do-query (#q(select * from chat where id > :id order by say_ts)
:id @id)
(html (:div :id $id :class :entry
(:div :class :say-ts $say_ts)
(:div :class :name $name)
(:div :class :content $content))))))

#|
(you::with-db clsql-sys:*default-database*
(execute-sql #q(delete from chat)))
|#

0 件のコメント: