ブログ書かなきゃ

Google Reader がなくなってブログ読まなくなったな。それであまり書かなくなった。というわけではない。

今年も鳥取に帰省した。だれもいなく、くらげもいなかった。

Common Lisp 関連は https://github.com/quek/unpyo を書いて遊んでる。

サーバプログラムでデバッガーの起動

Common Lisp でサーバプログラムを書いている時、エラーは (handler-case ... (error (e) ...) って感じで全てにぎりつぶしたい。

でも、そうすると開発中はデバッガ起動しなくて困る。

どうしよう・・・ということで Hunchentoot のソース読んでみた。 with-simple-restart で invoke-debugger をかこめばいいみたい。

次のようにすると変数1つでデバッガの起動するしないを切り替えられるんだね。

(defvar *invoke-debugger-p* t)

(defun my-debugger (e)
  (when *invoke-debugger-p*
    (with-simple-restart (continue "Return from here.")
      (invoke-debugger e))))

(defmacro with-debugger (&body body)
  `(handler-bind ((error #'my-debugger))
     ,@body))

;; サーバのループ処理イメージ
(loop for socket = (accept)
  do (handler-case
         (with-debugger (call socket))
       (error (e)
          (error-handle e))))

*invoke-debugger-p* を t にしておけばエラー発生時にデバッガがあがる。そのデバッガで Continue リスタートを選べば handler-case により error-handle がちゃんと呼ばれる。

invoke-debugger はそのままだと処理が戻らないから with-simple-restart でかこんであげるってことだね。

キー入力のカスタマイズ

腱鞘炎気味だったのでキー入力をちょっと変えみた。

• shift + 9 → <
• shift + 0 → >

がつらい感じだったので

• meta + , → <
• mata + . → >

にしてみた。

;; キー定義。
(set-sequence ((+any+ +no-meta+ +no-shift+ KEY_COMMA) (+any+ +shift+ KEY_9)) ;,         → (
              ((+any+ +shift+    KEY_COMMA)     (+any+ KEY_COMMA))           ;shift + , → ,
              ((+any+ +no-meta+ +no-shift+ KEY_DOT) (+any+ +shift+ KEY_0))   ;.         → )
              ((+any+ +shift+    KEY_DOT)       (+any+ KEY_DOT))             ;shift + . → .
              ((+any+ +shift+ KEY_9)            (+any+ +shift+ KEY_COMMA))   ;shift + 9 → <
              ((+any+ +shift+ KEY_0)            (+any+ +shift+ KEY_DOT))     ;shift + 0 → >
              ((+any+ +meta+ KEY_COMMA)         (+any+ +shift+ KEY_COMMA))   ;mata + ,  → <
              ((+any+ +meta+ KEY_DOT)           (+any+ +shift+ KEY_DOT)))    ;mata + .  → >

hu.dwim.walker を使ってみる

Common Lisp といえばマクロ。マクロのいきつく先といえばコードウォーカー。ということで hu.dwim.walker というコードウォーカ一を使ってみた。

使い方としては次のような感じ。

1. フォーム(S式)を hu.dwim.walker:walk-form で CLOS オブジェクトのAST(抽象構文木)にする。
2. AST を hu.dwim.walker:substitute-ast-if や hu.dwim.walker:rewrite-ast を使って書き換える。
3. hu.dwim.walker:unwalk-form で AST をフォーム(S式)に戻す。

cl-json を使うと次のように JSON をデコードできる。

(json:decode-json-from-string "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}")
;;⇒ ((:A . 1) (:B (:BB . 2)) (:C . 3))

これに対する assoc をちまち書きたくないので、シンボル1つで次のように展開されるマクロを書いてみる。

@a ⇒ (ASSOC "A" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL)
@b.bb ⇒ (CDR (ASSOC "BB"
                     (CDR (ASSOC "B" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL))
                     :TEST #'STRING-EQUAL))

これだけなら S式を単純に置換していくだけでも可能だけど

• @で始まるシンボルでも let 等で束縛されていれば、上記の展開を行なわない。
• マクロがネストされても問題ないようにする。

となるとコードウォーカーが必要になる。

ちゃんとしたドキュメントとかないようなので、テストやソースを見ながら書いたのがこれ。

(ql:quickload "hu.dwim.walker")
(ql:quickload "cl-json")
(ql:quickload "split-sequence")

(defun symbol-to-assoc-form (symbol decoded)
  (let ((names (split-sequence:split-sequence #\. (subseq (symbol-name symbol) 1))))
    (hu.dwim.walker:walk-form
     (reduce (lambda (acc x)
               `(cdr (assoc ,x ,acc :test #'string-equal)))
             names
             :initial-value decoded))))

(defun free-and-@-p (form)
  (and (typep form 'hu.dwim.walker:free-variable-reference-form)
       (char= #\@ (char (symbol-name (hu.dwim.walker:name-of form)) 0))))

(defun walk-with-json-body (decoded form env)
  (let* ((walked (hu.dwim.walker:walk-form form
                                           :environment (hu.dwim.walker:make-walk-environment env)))
         (walked (hu.dwim.walker:rewrite-ast
                  walked
                  (lambda (parent field form)
                    (declare (ignore parent field))
                    (if (free-and-@-p form)
                        (symbol-to-assoc-form (hu.dwim.walker:name-of form) decoded)
                        form)))))
    (hu.dwim.walker:unwalk-form walked)))

(defmacro with-json (json &body body &environment env)
  (let ((decoded (gensym)))
    `(let ((,decoded (json:decode-json-from-string ,json)))
       ,@(mapcar (lambda (form)
                   (walk-with-json-body decoded form env))
                 body))))

;; @a と @b.bb は json の値 1, 2 に @c は let の 999 になる。
;; with-json がネストしてても問題ない。
(with-json "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}"
  (let ((@c 999))
    (list @a @b.bb @c
          (with-json "{\"a\": 10, \"b\": {\"bb\": 20}, \"c\": 30}"
            (let ((@c 9990))
              (list @a @b.bb @c))))))
;;⇒ (1 2 999 (10 20 9990))

Common Lisp の MongoDB ドライバを作ってみた

cl-mongo があるのは知っていましたが、それでも Common Lisp の MongoDB ドライバを作ってみました。

• https://github.com/quek/info.read-eval-print.bson
• https://github.com/quek/info.read-eval-print.mongo

Quicklisp には入ってません。

いろいろ足りないかもしれませんが、とりあえず動きます。仕事でログ解析に使ったりしています。

;; 他にも https://github.com/quek/ の下にある何かが必要かも・・・
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; https://github.com/quek/info.read-eval-print.bson
  (ql:quickload :info.read-eval-print.bson)
  ;; https://github.com/quek/info.read-eval-print.mongo
  (ql:quickload :info.read-eval-print.mongo))

(defpackage :mongo
  (:use :cl)
  ;; SBCL の local-nicknames を使ってみたりする。これいいよね。
  (:local-nicknames (:m :info.read-eval-print.mongo)
                    (:b :info.read-eval-print.bson)))

(in-package :mongo)

(defvar *connection* (m:connect "localhost:27017"))
;;⇒ *CONNECTION*

(defvar *db* (m:db *connection* "test"))
;;⇒ *DB*

(defvar *foo* (m:collection *db* "foo"))
;;⇒ *FOO*

;; 登録する
(loop for i from 1 to 10
      do (m:insert *foo* (b:bson :a "hello" :b i)))
(m:insert *foo* (b:bson :a "world" :b 1))

;; 検索する。Series を使う。
(series:collect (m:scan-mongo *foo* nil))
;;⇒ ({"_id": ObjectId("51734E4BCF15ED0A74C21E61"), "a": "hello", "b": 1}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E62"), "a": "hello", "b": 2}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E63"), "a": "hello", "b": 3}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E64"), "a": "hello", "b": 4}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E65"), "a": "hello", "b": 5}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E66"), "a": "hello", "b": 6}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E67"), "a": "hello", "b": 7}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E68"), "a": "hello", "b": 8}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E69"), "a": "hello", "b": 9}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E6A"), "a": "hello", "b": 10}
;;    {"_id": ObjectId("51734E4DCF15ED0A74C21E6B"), "a": "world", "b": 1})

(series:collect (m:scan-mongo *foo* (b:bson (m:$< :b 3) :a "hello")))
;;⇒ ({"_id": ObjectId("51734E4BCF15ED0A74C21E61"), "a": "hello", "b": 1}
;;    {"_id": ObjectId("51734E4BCF15ED0A74C21E62"), "a": "hello", "b": 2})

Common Lisp でリフレッシュトークンを使って Google Analytics の Core Reporting API をたたく

oauth2 は https://github.com/Neronus/oauth2 を使う。

(defpackage oauth2.test.google-analytics
  (:use :cl :oauth2))

(in-package oauth2.test.google-analytics)


(defparameter *token*
  (oauth2::string->token ""
                         :refresh-token "your refresh token"
                         :scope "https://www.googleapis.com/auth/analytics.readonly"))

(defparameter *refreshed-token*
  (oauth2:refresh-token "https://accounts.google.com/o/oauth2/token" *token*
                        :method :post
                        :scope "https://www.googleapis.com/auth/analytics.readonly"
                        :other `(("client_id" . "your client id")
                                 ("client_secret" . "your client secret"))))

(let ((drakma:*text-content-types* '(("application" . "json"))))
  (json:decode-json-from-string
   (request-resource "https://www.googleapis.com/analytics/v3/data/ga"
                     *refreshed-token*
                     :parameters ' (("ids" . "ga:999999999")
                                    ("metrics" . "ga:pageviews")
                                    ("dimensions" . "ga:pagePath")
                                    ("start-date" . "2013-01-01")
                                    ("end-date" . "2013-01-03")))))

SBCL 1.1.5 で導入された package local nicknames

これはいい。

http://www.sbcl.org/manual/index.html#Package_002dLocal-Nicknames

CL-USER> (defpackage :foo.bar.baz (:use :cl))
#<PACKAGE "FOO.BAR.BAZ">
CL-USER> (defparameter foo.bar.baz::foo 1)
FBZ::FOO
CL-USER> (defpackage :aaa (:use :cl))
#<PACKAGE "AAA">
CL-USER> (defpackage :bbb (:use :cl))
#<PACKAGE "BBB">
CL-USER> (sb-ext:add-package-local-nickname :fbz :foo.bar.baz :aaa)
#<PACKAGE "AAA">
CL-USER> (in-package :aaa)
#<PACKAGE "AAA">
AAA> fbz::foo
1
AAA> (in-package :bbb)
#<PACKAGE "BBB">
BBB> fbz::foo
 ; Evaluation aborted on #<SB-INT:SIMPLE-READER-PACKAGE-ERROR "Package ~A does not exist." {1005DE7C93}>.
BBB> (sb-ext:add-package-local-nickname :fbz :foo.bar.baz)
#<PACKAGE "BBB">
BBB> fbz::foo
1