[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))))
|#