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

restart-bind とか使ってカッコよく再接続したいのだけど

最近 Common Lisp で MongoDB のドライバを書いたりしている。

restart-bind とか使ってカッコよく再接続したいのだけど、 try catch のエラーハンドリングから生長できない・・・

(defmacro with-reconnect-around (connection &key (max-retry-count 10) (retry-sleep 3))
  (let ((retry-count (gensym "retry-count")))
    `(loop for ,retry-count from 0
           do (handler-case (progn
                              (unless (zerop ,retry-count)
                                (establish-connection ,connection))
                              (return (call-next-method)))
                (error (e)
                  (when (< ,max-retry-count ,retry-count)
                    (signal e))
                  (warn "reconnecting... ~a" e)
                  (sleep ,retry-sleep)
                  (close ,connection))))))

(defmethod send :around ((self replica-set) op size function)
  (with-reconnect-around self))

(defmethod send ((connection connection) op size function)
  送信処理...)

• Lisp, the Universe and Everything: cl-redis: Separation of Concerns in Library Design
• ``Condition Handling in the Lisp Language Family'' c by Kent Pitman (2001)

このあたりを読んで、勉強しましょ。

Lisp Meet Up presented by Shibuya.lisp #1 に行ってきた

Lisp Meet Up presented by Shibuya.lisp #1 に行ってきた。

前半は chiku さんによる vim からの Common Lisp の使用についての発表。 swank クライアントしとて動く slimv がおすすめらしい。 vim の人は大変だなぁ、と思った。 vim は好きだけど slime があるから emacs から離れられない。

みんなで自己紹介した後、後半。後半はそれぞれで Common Lisp の処理系をインストールしたり、Lisp 系の会話でもりあがっいた。

私は @ravencoding さんと quicklisp をインストールしたり hunchentoot や clack を動かしたりしていた。

残念ながらバスの時間があるので 22 時前に早退。いいイベントだった。

cl-mongo を series で

cl-mongo を series で

(defun order-kv (order)
  (cond ((null order)
         nil)
        ((atom order)
         (cl-mongo:kv order 1))
        (t
         (apply #'cl-mongo:kv
                (mapcar (lambda (x)
                          (if (atom x)
                              (cl-mongo:kv x 1)
                              (cl-mongo:kv (car x)
                                           (if (eq :desc (cadr x)) -1 1))))
                        order)))))

(series::defS scan-mongo (collection query &key (skip 0) (limit 0) order)
  "scan mongoDB collection."
  (series::fragl
   ;; args
   ((collection) (query) (skip) (limit) (order))
   ;; rets
   ((doc t))
   ;; aux
   ((doc t) (cursor t) (count integer))
   ;; alt
   ()
   ;; prolog
   ((setq count 0)
    (setq cursor (cl-mongo:db.find
                  collection
                  (aif (order-kv order)
                       (cl-mongo:kv (cl-mongo:kv "query" query)
                                    (cl-mongo:kv "orderby" it))
                       query)
                  :skip skip
                  :limit limit)))
   ;; body
   (L
    (setq doc (pop (cadr cursor)))
    (unless doc
      (push nil (cadr cursor))
      (if (zerop (cl-mongo::db.iterator cursor))
          (go series::end)
          (progn
            (incf count (nth 7 (car cursor)))
            (if (and (plusp limit) (<= limit count))
                (go series::end)
                (progn
                  (setq cursor (cl-mongo:db.iter cursor :limit (- limit count)))
                  (pop (cadr cursor))
                  (go L)))))))
   ;; epilog
   ((cl-mongo:db.stop cursor))
   ;; wraprs
   ()
   ;; impure
   nil))

として

(iterate ((doc (scan-mongo "logs.app" (cl-mongo:$> "_id" last-id))))
  (foo doc))

な感じ。

Common Lisp で Amazon Glacier

Common Lisp で Amazon Glacier

https://github.com/quek/info.read-eval-print.aws.glacier

できた気するので、今度バックアップデータをアップロードしてみる。

たぶんアップロード時の description にファイル名とか日時とかサイズとか入れといた方がいい気がする。

(ql:quickload :info.read-eval-print.aws.glacier)

(in-package #:info.read-eval-print.aws.glacier)

(load "~/.info.read-eval-print.aws.glacier.lisp")

(list-vaults)

(create-vault "test-vault")

(describe-vault "test-vault")

(upload-archive "test-vault" "/tmp/a.txt" :description "upload-archive")

(upload-archive-multipart "test-vault" "~/archive/apache-solr-4.0.0-src.tgz" :description "multipart")

(list-jobs "test-vault")

(initiate-job "test-vault" :type :inventory-retrieval)
;⇒ "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_"

(describe-job "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_")

(get-job-output "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_")

;; ファイルに保存する
(with-open-stream (in (get-job-output-stream "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_"))
  (with-open-file (out "/tmp/job-out" :direction :output :if-exists :supersede
                                      :element-type '(unsigned-byte 8))
    (alexandria:copy-stream in out :element-type '(unsigned-byte 8))))

ダウンロード時は :element-type '(unsigned-byte 8) を指定すること。

車輪の再発明 〜 HTML の出力

CL-WHO を使えばいいのだけど、デフォルトでエスケープされないのと、 Compojure の tag#id.class という書き方がうらやましかったで作った。

https://github.com/quek/info.read-eval-print.html

(html (:ul#foo.bar.baz
       (loop for i from 1 to 3
             do (html (:ul :data-value i (format nil "<~a>" i))))))

で次の出力になる。

<ul id="foo" class="bar baz">
  <ul data-value="1">
    &lt;1&gt;
  </ul>
  <ul data-value="2">
    &lt;2&gt;
  </ul>
  <ul data-value="3">
    &lt;3&gt;
  </ul>
</ul>

CL-WHO を使っていた会社のブログをこれで書きなおしてやった。