2008/10/17

[Common Lisp] Lingr API

Common Lisp で Lingr API をたたいてみた。とりあえず observe できればいいかな、というレベルで。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :quek)
(require :drakma)
(require :cl-json)
(use-package :quek)
(use-package :drakma))

(defpackage for-with-json)

(defmacro! with-json (o!json &body body)
(let* (($-symbols (collect-$-symbol body))
(json-symbols (mapcar #'to-json-symbol $-symbols)))
`(json:json-bind ,json-symbols ,g!json
(let ,(mapcar #`(,_a (if (stringp ,_b) (remove #\cr ,_b) ,_b))
$-symbols json-symbols)
,@body))))

(eval-always
(defun $-symbol-p (x)
(and (symbolp x)
(char= #\$ (char (symbol-name x) 0))))

(defun to-json-symbol (symbol)
(intern (substitute #\_ #\-
(subseq (symbol-name symbol) 1))
:for-with-json))

(defun collect-$-symbol (body)
(let ($-symbols)
(labels ((walk (form)
(if (atom form)
(when ($-symbol-p form)
(pushnew form $-symbols))
(progn
(walk (car form))
(walk (cdr form))))))
(walk body))
$-symbols))
)

(defvar *key* "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")

(defun check-status (res)
(let ((json (json:decode-json-from-string res)))
(with-json res
(when (string/= "ok" $status)
(error "~a" res)))
json))

(defun session-create (&optional (key *key*))
(with-json
(http-request "http://www.lingr.com/api/session/create"
:method :post
:parameters `(("api_key" . ,key)
("format" . "json")))
$session))

(defvar *session* nil)

(defun room-enter (id nickname &key (session *session*))
(with-json
(http-request "http://www.lingr.com/api/room/enter?format=json"
:method :post
:parameters `(("session" . ,session)
("id" . ,id)
("nickname" . ,nickname)))
$ticket))

(defun room-get-messages (ticket counter &key
user-messages-only
(session *session*))
"observe を使いましょう。"
(check-status
(http-request
"http://www.lingr.com/api/room/get_messages?format=json"
:parameters `(("session" . ,session)
("ticket" . ,ticket)
("counter" . ,(princ-to-string counter))
("user_messages_only" . ,(if user-messages-only
"true"
"false"))))))

(defun room-observe (ticket counter &key (session *session*))
(check-status
(http-request "http://www.lingr.com/api/room/observe?format=json"
:parameters `(("session" . ,session)
("ticket" . ,ticket)
("counter" . ,(princ-to-string counter))))))

(defmacro! do-observe ((room nickname) &body body)
`(let* ((*session* (session-create))
(,g!ticket (room-enter ,room ,nickname)))
(with-json (room-get-messages ,g!ticket -1)
(loop with ,g!counter = $counter
do (with-json (room-observe ,g!ticket ,g!counter)
(when $counter ; ((:status "ok")) のみの場合があるので
,@body
(setf ,g!counter $counter)))))))


#|
(do-observe ("room" "nickname")
(loop for i in $messages
do (with-json i
(format t "~&~a: ~a" $nickname $text))))
|#

4 件のコメント:

kosh さんのコメント...

前触れなく使われている`eval-always'って何者なんでしょうか。
eval-whenの親戚?

Yoshinori Tahara さんのコメント...

あぁ、すみません。コード上にでてくる怪しげなのは (require :quek) している自前のライブラリです。
eval-always はこんなんです。
(defmacro eval-always (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@body))

あと defmacro! とか #` とかは Let On Lambda から拝借したものです。

kosh さんのコメント...

自前ライブラリでしたか。なるほどです。
LOLのコードはこれですね
http://letoverlambda.com/lol-orig.lisp
これでLingrをobserveできるとは、なかなか便利そうだなあ。

Yoshinori Tahara さんのコメント...

まさに LOL はそれです。
まぁ、既にあるもの(http://www.lingr.com/tools)を使った方がはるかに便利でしょうが CL でやってみるってのが重要なのでw