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

[Common Lisp] SQL その2

結局のところこんなふうになった。

(defaction todo ()
  (default-template (:title "TODO リスト")
    (html (:h1 "TODO リスト do-query #q")
          (:form
           (:input :type :text :name :q))
          (:table :border 1
                  (do-query
                      ((append #q(select * from todo)
                               (when @q #q(where content like :param)))
                       :param (string+ "%" @q "%"))
                    (html (:tr (:td $id)
                               (:td $content)
                               (:td $done))))))))

#q リーダマクロで SQL をそのまま書けるようにした。懐かしの埋め込み SQL だ。コンマとシングルクォートを set-macro-character しただけだが、結構 SQL をまともに read できそう。さすが Common Lisp.

SQL 中のパラメータはキーワードシンボルにして、キーワード引数で指定する。

検索結果は alist にしておいて $ で始まるシンボルで参照する。なので $ で始まるシンボルは (ASSOC "CONTENT" #:ASSOC1320 :TEST #'STRING-EQUAL) な感じにマクロ展開する。

• SQL 文は入力によって検索条件が変わるので実行時でないとクエリが確定しない。
• select * を使うと検索結果の列名はクエリ実行でないと分からない。

というような理由で実行時にがんばってしまうコードをはくマクロとなってしまった。効率悪そう。でも某フレームワークでは eval 使いまくっているって噂だから、まあいいか。

(defmacro with-db (var &body body)
  `(clsql:with-database (,var *connection-spec*
                              :database-type *database-type*
                              :if-exists :new
                              :pool t
                              :make-default nil)
     ,@body))

(defun |#q-quote-reader| (stream char)
  (declare (ignore char))
  (with-output-to-string (out)
    (loop for c = (read-char stream t nil t)
          until (and (char= #\' c)
                     (char/= #\' (peek-char nil stream nil #\a t)))
          do (progn
               (write-char c out)
               (when (char= c #\')
                 (read-char stream))))))

(defun |#q-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let ((*readtable* (copy-readtable nil)))
    (set-macro-character #\, {(declare (ignore _x _y)) :|,|})
    (set-macro-character #\' #'|#q-quote-reader|)
    `(quote ,(read stream t nil t))))

(set-dispatch-macro-character #\# #\q #'|#q-reader|)

(defgeneric >sql (x)
  (:method (x)
    (princ-to-string x))
  (:method ((x string))
    (string+ #\' (cl-ppcre:regex-replace-all "'" x "''") #\'))
  (:method ((x symbol))
    (substitute #\_ #\- (symbol-name x))))

(defun sexp>sql (sexp)
  (with-output-to-string (out)
    (loop for i in sexp
          do (typecase i
               (symbol (princ (>sql i) out))
               (list
                  (princ "(" out)
                  (princ (sexp>sql i) out)
                  (princ ")" out))
               (t (princ (>sql i) out)))
          do (princ " " out))))

(defun substitute-query-parameters (query parameters)
  (if parameters
      (substitute-query-parameters
       `(substitute ,(cadr parameters) ,(car parameters) ,query)
       (cddr parameters))
      query))

(defun make-query-result-assoc (row fields)
  (loop for r in row
        for f in fields
        collect (cons f r)))

(defmacro! do-query ((query &rest params) &body body)
  (labels ((result-symbol-p (x)
             (and (symbolp x) (head-p x "$")))
           (key-string (x)
             (subseq (symbol-name x) 1))
           (walk-body (body assoc)
             (if (atom body)
                 (if (result-symbol-p body)
                     `(cdr (assoc ,(key-string body) ,assoc
                                  :test #'string-equal))
                     body)
                 (cons (walk-body (car body) assoc)
                       (walk-body (cdr body) assoc)))))
    `(multiple-value-bind (,g!result ,g!field-names)
         (clsql-sys:query (sexp>sql
                           ,(substitute-query-parameters query params)))
       (loop for ,g!row in ,g!result
             for ,g!assoc = (make-query-result-assoc ,g!row ,g!field-names)
             do ,@(walk-body body g!assoc)))))

ここ数日のこと

• カオマイカンを作った。ひさしぶりのダッチオーブンは錆びてなかった。よかった。美味しかった。
• 幼稚園最後の運動会。すっかりその気でおどってましたな。
• 栗御飯を作った。秋ですな。
• 体調は回復したと思う。

[Commo Lisp] POP3 でのメール削除

全く使ってなかたプロバイダのメールをひさしぶりにチェックしてみたら4000通以上のメールがたまっていた。メーラーは Opera を使っているのだが、メールのフェッチ途中で落ちてしまう。どうせ SPAM メールばかりだから全部容赦なく消してしまうことにした。

さっぱりした。複数行のレスポンスは考慮してないし、認証もプレーンテキストなので。。。

(defparameter *host* "xxx")
(defparameter *user* "xxx")
(defparameter *pass* "xxx")

(require :usocket)

(defun snd (stream &rest message)
  (let ((message (format nil "~{~a~^ ~}~c~c" message #\cr #\lf)))
    (print (remove #\cr message))
    (write-string message stream)
    (force-output stream)))

(defun rev (stream)
  (print (remove #\cr (read-line stream nil))))

(usocket:with-client-socket (socket stream *host* 110)
  (rev stream)
  (snd stream :USER *user*)
  (rev stream)
  (snd stream :PASS *pass*)
  (rev stream)
  (snd stream :STAT)
  (destructuring-bind (state count size)
      (read-from-string (concatenate 'string "(" (rev stream) ")"))
    (loop for i from 1 to count
          do (snd stream :DELE i)
          do (rev stream)))
  (snd stream :QUIT)
  (rev stream))

[Common Lisp] アトムをコンスセルで繋いだソースと実行時表現とは無関係なんだ！(by onjo さん)

先日のことですが、どうしても次のような関数が作れなくって、Wassr に投下してみました。

(let ((x 1) (y 2) (q1 "x") (q2 "y"))
  (list (xxx q1) (xxx q2)
        (let ((x 10) (y 20))
          (list (xxx q1) (xxx q2)))))
;; => (1 2 (10 20)) となる関数 xxx

g000001 さんから こんなの や こんな 回答をもらい、さらに COMMON LISP JP(at Lingr) への投下を勧められたので投下してみました。
それでもらった回答が これ です。
その中でも onjo さんの「アトムをコンスセルで繋いだソースと実行時表現とは無関係なんだ！」という言葉が印象ぶかかったです。さすがですよね。
色々と考えてくださったみなさん、どうもありがとうございました。

[Common Lisp] with-ca/dr

わだばLisperになるさんのことでとりあげてもらったマクロ。実装はこんなふう。

defmacro! は Let Over Lambda に出てくるマクロで、o! で始まるシンボルは once-only マクロ、g! で始まるシンボルは with-gensym マクロと同じになる。

(defmacro! with-ca/dr (o!var &body body)
  `(let ((car (car ,g!var))
         (cdr (cdr ,g!var)))
     ,@body))

[Common Lisp] with-[]

わだばLisperになる(g000001)さんの添字的symbol-macroletがおもしろかったので、symbol-macrolet を使わないバージョンを書いてみた。Let On Lambda に出てきそうなやつ。

残念ながら h[foo] としてシンボル foo 自体をキーとすることができない。foo の値がキーになる。あと、setf もできない。

(require :cl-ppcre)

(defgeneric access-[] (obj index)
  (:method ((obj list) index)
    (nth index obj))
  (:method ((obj sequence) index)
    (elt obj index))
  (:method ((obj hash-table) index)
    (gethash index obj)))

(defmacro with-[] (&body body)
  (labels (([]-p (x)
             (when (symbolp x)
               (cl-ppcre:register-groups-bind (symbol index)
                   ("(.+)\\[(.+)\\]$" (symbol-name x))
                 (values symbol index))))
           (map-form (form)
             (cond ((atom form)
                    (multiple-value-bind (symbol index) ([]-p form)
                        (if symbol
                            `(access-[] ,(find-symbol symbol)
                                        ,(read-from-string index))
                            form)))
                   (t
                    (cons (map-form (car form))
                          (map-form (cdr form)))))))
    `(progn ,@(map-form body))))

(with-[]
  (let ((n 2)
        (l '(1 2 3))
        (s "hello")
        (h (make-hash-table)))
    (setf (gethash n h) "ハッシュ")
    (list l[n] s[n] h[n])))
;; => (3 #\l "ハッシュ")

#|
h[foo] とかして シンボル foo をキーにするのはできない。
setf もできない。
|#