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 を使っていた会社のブログをこれで書きなおしてやった。

generic な scan

こんな感じ。多値は。。。

(defgeneric scan% (thing &key &allow-other-keys))

(series::defS scan* (thing &rest args)
  "generic scan."
  (cl:let ((scan% `(scan% ,thing ,@args)))
    (series::fragl
     ;; args
     ((thing t)
      (scan% function))
     ;; rets
     ((value t))
     ;; aux
     ((value t)
      (f function))
     ;; alt
     ()
     ;; prolog
     ((setq f scan%))
     ;; body
     ((multiple-value-bind (v p) (funcall f)
        (unless p
          (go series::end))
        (setq value v)))
     ;; epilog
     ()
     ;; wraprs
     ()
     ;; impure
     nil)))

(defmethod scan% ((ting list) &key)
  (let ((x ting))
    (lambda ()
      (if x
          (let ((car (car x)))
            (setf x (cdr x))
            (values car t))
          (values nil nil)))))

(defmethod scan% ((thing array) &key (start 0) end)
  (let ((i start)
        (end (or end (length thing))))
    (lambda ()
      (if (= i end)
          (values nil nil)
          (let ((v (aref thing i)))
            (incf i)
            (values v t))))))

#|
(collect (scan* #(1 2 3)))
;⇒ (1 2 3)

(collect (scan* #(1 2 3) :start 1 :end 2))
;⇒ (2)

(defstruct st
  (value 'a)
  (next nil))

(defmethod scan% ((st st) &key)
  (lambda ()
    (if st
        (let ((x st))
          (setf st (st-next st))
          (values x t))
        (values nil nil))))

(let ((st (make-st :value 1 :next (make-st :value 2 :next (make-st :value 3)))))
  (collect (st-value (scan* st))))
;⇒ (1 2 3)
|#

「星降る草原」グインサーガ外伝23

ひさしぶりに読むグインサーガ。おもしろかった。自分の中の何かが満たされた。グインサーガは中学のころから読んでいて、生活の一部になっていたんだということを、認識した。

これかもずっと読んでいきたい。

標準入力を読むなら

(load "~/quicklisp/setup.lisp")

(let* ((*standard-output* (make-broadcast-stream))
       (*error-output* *standard-output*))
  (ql:quickload :series))

(use-package :series)

(write-string
 (collect 'string (scan-stream *standard-input* #'read-char)))

yarn:~% echo "hello\nworld" | sbcl --script /tmp/a.lisp
hello
world

sbcl --script でやるなら

昨日の Common Lisp から Skype を使う を sbcl —script でやるならこんな感じかな。

(load "~/quicklisp/setup.lisp")

(let* ((*standard-output* (make-broadcast-stream))
       (*error-output* *standard-output*))
  (ql:quickload :dbus))

(use-package :dbus)

(with-open-bus (bus (session-server-addresses))
  (with-introspected-object (skype
                             bus
                             "/com/Skype"
                             "com.Skype.API")
    (flet ((skype (command)
             (skype "com.Skype.API" "Invoke" command)))
      (skype "NAME FromCommonLisp")
      (skype "PROTOCOL 8")
      ;; #xxx... はチャットルームの ID
      (skype (format nil "CHATMESSAGE #xxxxxxx/$yyyyyyy;9999aaaa9999 ~a"
                     (second sb-ext:*posix-argv*))))))

sbcl --script skype.lisp "hello"

Common Lisp から Skype を使う

なんだ。簡単だった。

dbus 経由。

リファレンス http://developer.skype.com/public-api-reference#Linux

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :dbus))

(defpackage :try-dbus
  (:use :cl :dbus))

(in-package :try-dbus)

(with-open-bus (bus (session-server-addresses))
  (with-introspected-object (skype
                             bus
                             "/com/Skype"
                             "com.Skype.API")
    (flet ((skype (command)
             (skype "com.Skype.API" "Invoke" command)))
      (print (skype "NAME FromCommonLisp"))
      (print (skype "PROTOCOL 8"))
      (print (skype "GET USERSTATUS"))
      (print (skype "PING"))
      ;; #xxx... はチャットルームの ID
      (skype "CHATMESSAGE #xxxxxxx/$yyyyyyy;9999aaaa9999 てすとです(f)"))))

夏休み

20日(月)から24日(金)まで鳥取に帰省していた。ニ年ぶりの帰省。

20日(月)

飛行機で羽田から米子へ。

米子空港の名前が米子鬼太郎空港にかわっていた。

家でバーベキューをして、家の裏の暗がりから天の川をながめた。

お風呂は白鳳の里。

21日(火)

水木しげるロードと、水木しげる記念館に行った。

水木しげるロードは以前よりブロンズ像がずっと増えていて、おもしろくなっていた。

水木しげる記念館は初めて入った。思っていたよりずっとよかった。壁に直筆の鬼太郎が描いてあったり、妖怪の模型や説明が充実してたり、うちの小学4年生もおおいに楽しんでいた。〇〇記念館の類の中でも秀逸だと思う。

「お魚天国すし若竹内団地２号店」で食事をして、夢みなとタワーに行った。「動物地球館」という移動動物園(?)を見た。ゾウガメに触れたのがよかった。しっぽがかわいい。

お風呂はうなばら荘。

22日(水)

午前中は近くの海へ海水浴に行った。お盆を過ぎているとはいえ、誰一人いなかった。プライベートビーチ。カモメと白鳥とクラゲ(2匹だけ)しかいなった。

午後は大山の森の国に行って、アスレチックで遊んだ。臆病な(それとも慎重派?)うちの子は、ろくにクリアできなかったけど、とても楽しかったらしい。

23日(木)

青山剛昌ふるさと館の方に行った。ちょうど「名探偵コナン 巨大迷路で少年探偵団を探せ！」というのやっていたので、迷路で遊んだ。

青山剛昌ふるさと館の方は。。。水木しげるロードと、水木しげる記念館はすごいな、という感じ。

お風呂は湧くわく天然温泉ラピスパ。

24日(金)

空港に行く前に、回転寿司「大漁丸 境港店」に行った。イワシと生サバが美味しかった。

米子鬼太郎空港から羽田へ。

logtest

Common Lisp になら、あるんじゃないかなと思ったら、やっぱりあった。

(not (zerop (logand event-mask isys:epollin)))

は

(logtest event-mask isys:epollin)

http://www.lispworks.com/documentation/HyperSpec/Body/f_logtes.htm

http://www.lispworks.com/documentation/HyperSpec/Body/c_number.htm このへんは知らないのいっぱいある。

Common Lisp で thread + epoll の Web サーバを作ってみた

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

(info.read-eval-print.httpd:start (make-instance 'info.read-eval-print.httpd:server))

ab -n 10000 -c 10 'http://localhost:1958/sbcl-doc/html/index.html'

Linux + SBCL にべったりで GET に対してファイルを返せるだけ。

システムコールばかりなので性能は悪くない感じ。

Debian sid に Skype をインストールする

http://wiki.debian.org/skype に書いてあるとおり。

sudo dpkg --add-architecture i386
sudo apt-get update
wget -O skype-install.deb http://www.skype.com/go/getskype-linux-deb
sudo dpkg -i skype-install.deb

ひっかかったら

sudo apt-get -f install

Skype のバージョン 4.0.0.7 になってた。この前まで 2.x.x? beta だったのに。画面の共有もできるようになったようだ。

だいたいこれくらい動いちゃうと

満足して実装したい衝動が消えちゃう。。。

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

(establish-connection)

(defrecord prefecture ()
  ()
  (:has-many :facilities))

(defrecord facility ()
  ()
  (:belongs-to :prefecture)
  (:has-many :experiences :as :experiencable))

(defrecord experience ()
  ()
  (:belongs-to :experiencable :polymorphic t))

(let ((facilities (with-ar (facility)
                    (where "name like ?" "%水族館")
                    (where :publish 1)
                    (order :name)
                    (get-list))))
  (values
   (mapcar #'name-of facilities)
   (name-of (prefecture-of (car facilities)))))

(facilities-of (with-ar (prefecture)
                 (where "id = 1")
                 (get-first)))

(experiences-of (with-ar (facility)
                  (get-first)))

(experiencable-of (with-ar (experience)
                    (get-first)))

(with-ar (facility)
  (joins :prefecture)
  (where :prefectures.name "鳥取県")
  (get-list))

Common Lisp ならスペシャル変数とマクロで

ときどき Active Record を Common Lisp で実装したくなる。それでひっかかるものの一つがメソッドチェーン。

Ralis の Active Record Query Interface や jQuery や S2JDBC とか、メソッドチェーン多いよね。でも、Common Lisp だとメソッドチェーンはやりにくい。

リーダマクロという手はあるが、 Common Lisp らしくスペシャル変数と with 系マクロでいきたいと思う。

こんな感じになる。

(with-ar (facility)
  (where "name like ?" "%水族館")
  (when only-published-p
    (where :publish 1))
  (order :name)
  (get-list))

with-ar でかこんで、後は普通に関数呼び出し。メソッドチェーンは条件分岐があるとめんどうだけで、普通の関数呼び出しだから when や if の条件分岐とかも間に入れられる。

次のような defvar と defmacro だけで簡単にできちゃう。

(defvar *association* nil "association")

(defmacro with-ar ((table) &body body)
  `(let ((*association* (ensure-association ,table)))
     ,@body))

好きな言語がスペシャル変数とマクロのある言語でよかった。

rm -rf ~/.opera

Opera の調子がずっとよくなかった。 Facebook, Twitter がまともに動かない。エクステンションはことごとく「XML の解析に失敗しました」といエラーになる。

いいかげん他のブラウザを使うべきもかしれないと、本気で考えていた。他のブラウザにするぐらいなら ~/.opera を捨ててみるか、と rm -rf ~/.opera してみた。

全てが解決した。バージョン 8 くらいから使い続けていた ~/.opera だったので、最近の Opera ではいろいろと不都合があったのでしょう。

モチベーション 3.0

ダニエル・ピンクの「モチベーション 3.0」を読んだ。よかった。「自律」について私が感じていることを、見事に説明してくれた。

しかし、一つだけわからないことが。何でこの本借りたんだろう? 私があまり読まなさそうなタイプの本なのに。

usocket の使い方をすっかり忘れてしまっていた

サーバ側

(defparameter *port* 1958)

(defgeneric server-start (server))
(defgeneric server-stop (server))


(defclass* server ()
  ((host usocket:*wildcard-host*)
   (port *port*)
   (listen-thread nil)))

(defmethod server-start ((server server))
  (setf (listen-thread-of server)
        (sb-thread:make-thread
         (lambda ()
           (usocket:with-socket-listener (socket (host-of server) (port-of server) :reuse-address t)
             (loop (usocket:with-connected-socket (connected-socket
                                                   (usocket:socket-accept socket))
                     (let ((stream (usocket:socket-stream connected-socket)))
                       (print (eval (read stream)) stream)
                       (force-output stream))))))
         :name "nunumo:server")))

(defmethod server-stop ((server server))
  (sb-thread:terminate-thread (listen-thread-of server))
  (setf (listen-thread-of server) nil))

クライアント側

(defgeneric client-open (client))
(defgeneric client-close (client))
(defgeneric client-read (client))
(defgeneric client-write (client object))
(defgeneric client-flush (client))

(defclass* client ()
  ((host "localhost")
   (port *port*)
   (socket nil)
   (stream nil)))

(defmethod client-open ((client client))
  (setf (socket-of client)
        (usocket:socket-connect (host-of client) (port-of client))
        (stream-of client)
        (usocket:socket-stream (socket-of client)))
  client)

(defmethod client-close ((client client))
  (force-output (stream-of client))
  (usocket:socket-close (socket-of client))
  client)

(defmethod client-read ((client client))
  (read (stream-of client)))

(defmethod client-write ((client client) object)
  (print object (stream-of client)))

(defmethod client-flush ((client client))
  (force-output (stream-of client))
  client)

はい。RPC システム完成!

(let ((server (make-instance 'server))
      (client (make-instance 'client)))
  (server-start server)
  (unwind-protect
       (progn
         (client-open client)
         (client-write client '(format nil "(+ 1 2) => ~a" (+ 1 2)))
         (client-flush client)
         (client-read client))
    (server-stop server)))
;;=> "(+ 1 2) => 3"

sb-concurrency:queue

sb-concurrency:queue を使ってみる。

(defstruct (thread-pool (:constructor %make-thread-pool))
  (queue)
  (name)
  (stop)
  (sleep-time)
  (threads))

(defun make-thread-pool (number-of-thread &key
                                            name
                                            (sleep-time 0.1))
  (let ((stop (cons nil nil))
        (queue (sb-concurrency:make-queue)))
    (%make-thread-pool
     :name name
     :queue queue
     :stop stop
     :sleep-time sleep-time
     :threads (collect 'bag
                (sb-thread:make-thread
                 (lambda ()
                   (loop until (car stop)
                         do (multiple-value-bind (job ok)
                                (sb-concurrency:dequeue queue)
                              (if ok
                                  (funcall job)
                                  (sleep sleep-time)))))
                 :name (format nil "~a worker thread ~d" name
                               (scan-range :from 1 :upto number-of-thread)))))))

(defun stop-thread-pool (thread-pool)
  (setf (car (thread-pool-stop thread-pool)) t))

(defun join-thread-pool (thread-pool)
  (stop-thread-pool thread-pool)
  (collect-ignore (sb-thread:join-thread (scan (thread-pool-threads thread-pool)))))

(defun add-job (thread-pool job)
  (sb-concurrency:enqueue job (thread-pool-queue thread-pool)))

(defun wait-thread-pool (thread-pool)
  (loop until (sb-concurrency:queue-empty-p (thread-pool-queue thread-pool))
        do (sleep (thread-pool-sleep-time thread-pool))))

(defmacro with-thread-pool ((var number-of-thread
                             &key
                               (name "nunumo::thread-pool")
                               (sleep-time 0.1) )
                            &body body)
  `(let ((,var (make-thread-pool ,number-of-thread
                                :name ,name
                                :sleep-time ,sleep-time)))
     (unwind-protect
          (progn ,@body)
       (stop-thread-pool ,var))))

#|
(labels ((fib (n)
           (if (<= n 2)
               1
               (+ (fib (1- n))
                  (fib (- n 2))))))
  (let ((q (sb-concurrency:make-queue)))
    (with-thread-pool (pool 4)
      (dotimes (i 10)
        (add-job pool (let ((n (+ 31 i)))
                        (lambda ()
                          (sb-concurrency:enqueue (cons n (fib n)) q)))))
      (wait-thread-pool pool)
      (join-thread-pool pool))
    (sb-concurrency:list-queue-contents q)))
;;=> ((31 . 1346269) (32 . 2178309) (33 . 3524578) (34 . 5702887) (35 . 9227465) (36 . 14930352) (37 . 24157817) (38 . 39088169) (39 . 63245986) (40 . 102334155))
|#

Paiprolog の出番だ

某問題を解こうと思って Paiprolog の出番だ、と思ったがうまく行かなかった。

(ql:quickload  :paiprolog)

(defpackage :dropquest2012
  (:use :cl :paiprolog))

(in-package dropquest2012)

(<-- (member ?item (?item . ?rest)))
(<- (member ?item (?x . ?rest)) (member ?item ?rest))
(<-- (d ?x) (member ?x (0 1 2 3 4 5 6 7 8 9)))

(prolog-collect (?n1 ?n2 ?n3 ?n4 ?n5)
  (d ?n1)
  (d ?n2)
  (d ?n3)
  (d ?n4)
  (d ?n5)
  (is 24 (* ?n1 ?n2))
  (is ?n4 (/ ?n2 2))
  (is 26 (+ ?n1 ?n2 ?n3 ?n4 ?n5))
  (is ?n5 (+ ?n2 ?n3))
  (is (+ ?n4 ?n5) (+ ?n1 ?n3)))
;;=> NIL

でも、こうすると動く。

(prolog-collect (?n1 ?n2 ?n3 ?n4 ?n5)
  (d ?n1)
  (d ?n2)
  (d ?n3)
  (d ?n4)
  (d ?n5)
  (is 24 (* ?n1 ?n2))
  (is ?n4 (/ ?n2 2))
  (is 26 (+ ?n1 ?n2 ?n3 ?n4 ?n5))
  (is ?n5 (+ ?n2 ?n3))
  ;; (is (+ ?n4 ?n5) (+ ?n1 ?n3))
  (is ?x (+ ?n4 ?n5))
  (is ?x (+ ?n1 ?n3)))
;;=> ((6 4 5 2 9))

なんだろうね。

Series でも解きたくて scan-combination を実装した。

(ql:quickload  :info.read-eval-print.series-ext)

(info.read-eval-print.series-ext:sdefpackage :dropquest2012
                                             (:use :cl))

(in-package dropquest2012)

(collect-first
 (choose-if
  (lambda (xs)
    (destructuring-bind (n1 n2 n3 n4 n5) xs
      (and (= (* n1 n2) 24)
           (= n4 (/ n2 2))
           (= (+ n4 n5) (+ n1 n3))
           (= 26 (+ n1 n2 n3 n4 n5))
           (= n5 (+ n2 n3)))))
  (scan-combination 5 (collect (scan-range :upto 9)))))
;;=> ((6 4 5 2 9))

MySQL でフェッチしながら他の SQL を実行

MySQL でフェッチしながら他の SQL を実行しようとするとよく "Commands out of sync; you can't run thiscommand now" というエラーになる。

大きな検索結果のときどうすりゃいいんだろう? というのがかねてからの疑問だった。

MySQL のクライレアント API を理解するために SWIG を使って Common Lisp から API をたたいてみた。

;; swig でコードを生成する。
(quicklisp:quickload :trivial-shell)
(with-open-file (out "/tmp/input.i" :direction :output :if-exists :supersede)
  (write-string "%module input
%include \"/usr/include/mysql/mysql.h\"" out))
(trivial-shell:shell-command "swig -cffi /tmp/input.i")

;; libmysqlclient をロードする
(quicklisp:quickload :cffi)
(cffi:define-foreign-library libmysqlclient
  ((:not :windows) (:default "libmysqlclient"))
  (:windows (:default "libmysql")))
(cffi:use-foreign-library libmysqlclient)

;; swig で生成したコードをロード
(load "/tmp/input.lisp")

;; MySQL に接続
(mysql_server_init -1 (cffi-sys:null-pointer) (cffi-sys:null-pointer))
(setf mysql (mysql_init (cffi-sys:null-pointer)))
(setf connection (mysql_real_connect mysql "localhost" "root" "" "outing_development" 0 "/var/run/mysqld/mysqld.sock" 0))
(mysql_set_character_set mysql "utf8")

;; クエリー行実 mysql_store_result
(mysql_query connection "select * from regions")
(setf result (mysql_store_result connection))
(loop for row = (mysql_fetch_row result)
      until (cffi-sys:null-pointer-p row)
      do (loop for i below (mysql_num_fields result)
               do (format t "~a " (cffi:mem-aref row :string i))
               finally (terpri)))
(mysql_free_result result)

;; クエリー行実 mysql_use_result
(mysql_query connection "select * from regions")
(setf result (mysql_use_result mysql))
(loop for row = (mysql_fetch_row result) ; このループを最後まで回らないと "Commands out of sync; you can't run this command now"
      until (cffi-sys:null-pointer-p row)
      do (loop for i below (mysql_num_fields result)
               do (format t "~a " (cffi:mem-aref row :string i))
               finally (terpri)))
(mysql_free_result result)

;; おしまい
(mysql_close connection)
(mysql_server_end)

mysql_fetch_row を使った場合は最後(null が返っくる)まで mysql_fetch_row をしないと "Commands out of sync; you can't run this command now" というエラーになる。ここに書いてある。

Common Lisp でコード書かなくてもマニュアルを読めばよかったんだけど、隠れた動機というやつかな。

で、結局のところフェッチしながら他の SQL を実行するにはどうすればいいか? よくわからん。

Rails の find_each なんかは何回かに分けて mysql_store_result している感じなんだろうか?

そんなことより、SWIG 使えば C のコードを一行も書かずに Common Lisp だけで C の API をたたけて実にすばらしい。

ここしばらく

GW 対策でバタバタしていた。 GW に入る前はプログラマで GW に入ってからはインフラ屋さんな感じ。そろそろちょっとのんびりしたい。

今年の誕生日はジューサーを買った。3千円と安かったけど、ちゃんと動く。しぼりたてのジュースは美味しい。

娘は GW 前の一週間風邪でダウン。インフルエンザではないとの診断だったが高熱が3,4日続く質の悪い風邪だった。そしてまた今日も体調悪くてダウン。あわれ。四月末に一回遠出できたのはよかった。楽しそうだったし。回復したら今日行く予定だった映画に連れて行こう。

「さくらのVPS」ご利用中のお客様の新プラン乗り換え優遇施策

こどもの体調がわるく予定キャンセルで時間ができたので、新プランに乗り換えてた。 実施期間延長されててよかった。

すんなり Debian sid が入った。これでメモリ 1G で HD 100G だ。

Final reminder to update your legacy Blogger account

Final reminder to update your legacy Blogger account
とかいうメールが来たけど。。。
リンク先のパスワード入力する画面が http だからやめ、放置しとこう。

『内なる宇宙』

これはちょっと違った感じ。ちょっと納得できなかった。

www.box.com をマウントする

Linux Forums - Mount your box.net (box.com) account in linux

sudo apt-get install davfs2

sudo vi /etc/davfs2/secrets

https://www.box.com/dav user@email.com password

sudo vi /etc/davfs2/davfs2.conf

use_locks       0

sudo mount -t davfs -o uid=ancient,gid=ancient https://www.box.com/dav /mnt

rsync -av ~/letter/music /mnt

やたらエラーになるのは、そういうものなのだろうか? 日本語ファイル名が結構だめな感じ。

Amazon Web Service (AWS) についてのメモ

情報

• Discussion Forums
• Amazon EC2性能検証！気になるパフォーマンスをインスタンスタイプやリージョン毎に計測・比較してみた

一般

• Service Health Dashboard
• AWS Account Number とは? https://forums.aws.amazon.com/message.jspa?messageID=51585 Account Activity ページの 口座番号 https://aws-portal.amazon.com/gp/aws/securityCredentials の下の方の AWS アカウント ID '-' はとって入力する。

EC2

"NETWORK & SECURITY" "Security Groups" で Inbound の設定を行う。 ssh の IP アドレス制限は必須。 22 123.123.123.123/32 自宅

インスタンス作成時の key pair で ssh ssh したら、いつもの ssh キーを登録すればいい。

Amazon EC2 API Tools

Amazon EC2 API Tools : Developer Tools : Amazon Web Services からダンウロード

unzip して vi ~/.zshrc

# Amazon EC2 API Tools
export JAVA_HOME=/usr/lib/jvm/default-java
export EC2_HOME=~/local/opt/ec2-api-tools
export PATH=$EC2_HOME/bin:$PATH
export EC2_PRIVATE_KEY=~/.ec2/pk-HKZYKTAIG2ECMXYIBH3HXV4ZBEXAMPLE.pem
export EC2_CERT=~/.ec2/cert-HKZYKTAIG2ECMXYIBH3HXV4ZBEXAMPLE.pem
export EC2_URL=https://ec2.ap-northeast-1.amazonaws.com
export EC2_REGION=ap-northeast-1

EC2_PRIVATE_KEY と EC2_CERT は https://aws-portal.amazon.com/gp/aws/securityCredentials から取得する X.509 証明書。 EC2_URL は ec2-describe-regions コマンド調べる。

Auto Scaling Tools

http://docs.amazonwebservices.com/AutoScaling/latest/GettingStartedGuide/SetupCLI.html

export AWS_AUTO_SCALING_HOME=~/local/opt/AutoScaling
export PATH=$PATH:$AWS_AUTO_SCALING_HOME/bin

Elastic Load Balancing API Tools

Elastic Load Balancing API Tools : Developer Tools : Amazon Web Services からダウンロード

export AWS_ELB_HOME=~/local/opt/ElasticLoadBalancing
export PATH=$AWS_ELB_HOME/bin:$PATH

elb-describe-lbs --region=ap-northeast-1

ではだめ

elb-describe-lbs --region=ap-northeast-1

—region を指定すると動く。。。

export EC2_REGION=ap-northeast-1

すればよかった。

Amazon CloudWatch Command Line Tool

http://aws.amazon.com/developertools/2534

export AWS_CLOUDWATCH_HOME=~/local/opt/CloudWatch
export PATH=$AWS_CLOUDWATCH_HOME/bin:$PATH

ssh

Instance を右クリック "Connect" をクリック Example 表示されている次のコマンドで ssh 接続できる。

AMI

Debian の AMI http://wiki.debian.org/Cloud/AmazonEC2Image

Creating an Image from a Running Instance

EBS なら Instance を右クリックして Create Image で作成できる。作成時インスタンスは再起動される。

"IMAGES" "AMIs" に表示されるので、右クリックして "Launch Insnance" で新しいマシンをぽんぽん作れる。

メール送信

メール送信については制限があり、次のフォームから制限解除申請を行う。 https://aws-portal.amazon.com/gp/aws/html-forms-controller/contactus/ec2-email-limit-rdns-request

スパムメールにならないように、次の対策を行う。 Amazon EC2のサーバからメール送信をするまでにやるべきこと (スパムメール扱いを回避する！) - RX-7乗りの適当な日々

ip アドレス

ec2-nnn-nnn-nnn-nnn.ap-northeast-1.compute.amazonaws.com を EC2 内部で名前解決するとプライベートアドレスを取得できる。 https://forums.aws.amazon.com/thread.jspa?threadID=54973

ec2-describe-instances を使って動的な IP アドレスを取得することもできるらしい。

[[http://d.hatena.ne.jp/Craftworks/20100717/1279354708][動的に変わる EC2 のインスタンスの IP アドレスを自動収集するスクリプト書いた

Craftworks Tech Blog - Branch]]

Elastic Load Balancing

簡単で作れた。 EC2 のインスンスを指定する。

CloudFront

S3 だけじゃなく任意のドメインのコンテンツのフロントになれる。

無効化については、ファイル名にバージョンを付けて管理するのが推奨らしい。 http://docs.amazonwebservices.com/AmazonCloudFront/latest/DeveloperGuide/ReplacingObjects.html

作成に数分かかる。停止にも数分かかる。

Security Group

Inbound の Source にセキュリティグループを指定できる。

『星を継ぐもの』、『ガニメデの優しい巨人』、『巨人たちの星』

いずれもとてもおもしろかった。『内なる宇宙』はこれから読む。楽しみだ。

本番に速く科学技術が発展するといいなと思う。

gnome-termial から mlterm + tmux にした

gnome-termial でちょうどいい行間でのビットマップフォント表示ができなくて、 mlterm + tmux を使ってみることにした。

17 インチノートならアンチエイリアスかかったフォントでもよかったけど、 ThinkPad X220 ではビットマップフォントの方がずっといい。

~/.stumpwmrc

(defcommand mlterm () ()
  "mlterm with tmux"
  (run-or-raise "mlterm -e sleep-and-tmux" '(:class "mlterm")))
(define-key *root-map* (kbd "C-p") "mlterm")

tmux の起動が Stumpwm によって mlterm が最大化表示になった後となるように、次のファイルを用意した。

sleep-and-tmux

#!/bin/sh

sleep 0.1 && tmux attach || tmux

~/.tmux.conf

unbind C-b
set-option -g prefix C-z
bind C-z send-prefix
set-window-option -g mode-keys vi
bind-key Space last-window
bind-key l next-layout
set-option -g history-limit 9999

~/.mlterm/main

scrollbar_mode = none
fg_color = gray
bg_color = black
fontsize = 13
col_size_of_width_a = 1
use_anti_alias = false
type_engine = xcore
receive_string_via_ucs = true
mod_meta_mode = esc

~/.mlterm/font

DEFAULT = 13,-mplus-gothic-medium-r-normal-*-13-*-*-*-c-*-

ファイルの変更監視を Series で

特定のディレクトリの下のファイル変更を監視したくて書いてみた。

;; /tmp の下をファイルの変更を 3 回だけ検知する。
(collect-ignore
 (subseries (format t "~&~a !!!!!!!!!!!!" (scan-file-change "/tmp/*.*"))
            0 3))

こんなふうに色々と scan-xxx にするとおもしろいかもしれない。

(defun collect-file-write-date-map (path)
  (let ((file (scan-directory path)))
    (collect-map file (file-write-date file))))

(series::defS scan-file-change (path &key (interval 1))
  "(scan-file-change path [:interval 1])"
  (series::fragl
   ;; args
   ((path) (interval))
   ;; rets
   ((file t))
   ;; aux
   ((map fset:map)
    (file t)
    (new-wirte-date t)
    (old-write-date t)
    (files t))
   ;; alt
   ()
   ;; prolog
   ((setq map (collect-file-write-date-map path))
    (sleep interval)
    (setq files (generator (scan-directory path))))
   ;; body
   (L
    (setq file (next-in files
                        (sleep interval)
                        (setq files (generator (scan-directory path)))
                        (next-in files)))
    (setq old-write-date (fset:@ map file))
    (setq new-wirte-date (file-write-date file))
    (if (and old-write-date (= old-write-date new-wirte-date))
        (go L)
        (setq map (fset:with map file new-wirte-date))))
   ;; epilog
   ()
   ;; wraprs
   ()
   ;; impure
   nil))

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

fset:map も Series 化してみた

Series は sequence と hash-table は別関数なので FSet の場合でも map だけは別あつかいかな。

(series::defS scan-map (map)
  "(scan map)

Scans the entries of the fset:map and returns two series containing
the keys and their associated values.  The first element of key series
is the key of the first entry in the fset:map, and the first element
of the values series is the value of the first entry, and so on.  The
order of scanning the fset:map is not specified."
  (series::fragl ((map))               ; args
                 ((keys t) (values t)) ; rets
                 ((keys t) (values t)  ; aux
                  (mapptr t map))
                 ()                                          ; alt
                 ()                                          ; prolog
                 ((if (fset:empty? mapptr) (go series::end)) ; body
                  (multiple-value-bind (key val) (fset:arb mapptr)
                    (setq keys key)
                    (setq values val))
                  (setq mapptr (fset:less mapptr keys)))
                 ()                     ; epilog
                 ()                     ; wraprs
                 nil))

(series::defS collect-map (keys values &optional default-value)
  "(collect-map keys values)

Combines a series of keys and a series of values together into a map of fset.
default-value is defalt of fset:empty-map."
  (series::fragl ((keys t) (values t) (default-value t))
                 ((map))
                 ((map 'fset:map (fset:empty-map default-value)))
                 ()
                 ()
                 ((setq map (fset:with map keys values)))
                 ()
                 ()
                 nil)
  :trigger t)

;; キーと値をひっくり返した map を返す。
(multiple-value-bind (k v)
    (scan-map (fset:map ('a 1) ('b 2) ('c 3)))
  (collect-map v k 'not-found))
;;=> #{| (1 A) (2 B) (3 C) |}/NOT-FOUND

FSet を Series 化してみて思ったこと

FSet は Cliki の Current recommended libraries になっているコレクションライブラリ。そうなんだ。

確かになんかよさそう。

でも mapcar にあたる image は引数にコレクションを一つしかとれないの? という疑問に対して、たいして調べることなく scan-fset と collect-fset を定義して Series 化してみた。

FSet と Series と相性いいんじゃないかな。

(series::defS scan-fset (fset)
  "scan fset"
  (series::fragl ((fset))               ; args
                 ((items t))            ; rets
                 ((items t)             ; aux
                  (fsetptr t fset)
                  (seqp boolean))
                 ()                                           ; alt
                 ((setq seqp (fset:seq? fset)))               ; prolog
                 ((if (fset:empty? fsetptr) (go series::end)) ; body
                  (if seqp
                      (progn
                        (setq items (fset:first fsetptr))
                        (setq fsetptr (fset:less-first fsetptr)))
                      (progn
                        (setq items (fset:arb fsetptr))
                        (setq fsetptr (fset:less fsetptr items)))))
                 ()                     ; epilog
                 ()                     ; wraprs
                 nil))                  ; impure

(series::defS collect-fset (seq-type &optional (items nil items-p))
  "(collect-fset [type] series)"
  (let ()
    (unless items-p
      (setq items seq-type)
      (setq seq-type 'fset:bag))
    (cond ((eq seq-type 'fset:bag)
           (series::fragl ((items t)) ((bag))
                          ((bag 'fset:bag (fset:bag)))
                          ()
                          ()
                          ((setq bag (fset:with bag items)))
                          ()
                          ()
                          nil))
          ((eq seq-type 'fset:seq)
           (series::fragl ((items t)) ((seq))
                          ((seq 'fset:seq (fset:seq)))
                          ()
                          ()
                          ((setq seq (fset:with seq (fset:size seq) items)))
                          ()
                          ()
                          nil))
          ((eq seq-type 'fset:set)
           (series::fragl ((items t)) ((set))
                          ((set 'fset:set (fset:set)))
                          ()
                          ()
                          ((setq set (fset:with set items)))
                          ()
                          ()
                          nil))))
  :trigger t)

(collect-fset (* (scan-fset (fset:set 1 2 3))
                 (scan-fset (fset:seq 1 2 3))
                 (scan-fset (fset:bag 1 2 3))
                 (scan-fset (fset:map (1 'a) (2 'b) (3 'c)))))
;;=> #{% 1 16 81 %}

(collect-fset (scan-fset (fset:seq 1 2 2 3)))
;;=> #{% 1 (2 2) 3 %}
(collect-fset 'fset:bag (scan-fset (fset:seq 1 2 2 3)))
;;=> #{% 1 (2 2) 3 %}
(collect-fset 'fset:seq (scan-fset (fset:seq 1 2 2 3)))
;;=> #[ 1 2 2 3 ]
(collect-fset 'fset:set (scan-fset (fset:seq 1 2 2 3)))
;;=> #{ 1 2 3 }

Common Lisp で全文検索 Web システム

仕事で使えないかなと思って、 Common Lisp で全文検索 Web システムを作ってみたが、あまり速くなかった。

Montezuma に MeCab のトークナイザを付けて、 IOLib 使ったイベント方式の Web サーバでインターフェースを提供する実装。

Montezuma をファイルベースのインデックにすると厳しい。インメモリのインデックスならチューニングすればいけるかも。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :montezuma)
  (ql:quickload :clsql)
  (ql:quickload :info.read-eval-print.series-ext)
  (ql:quickload :info.read-eval-print.mecab)
  (ql:quickload :info.read-eval-print.web-server))

(info.read-eval-print.series-ext:sdefpackage
 :fts (:use :cl :info.read-eval-print.mecab
            :info.read-eval-print.web-server))

(in-package :fts)


;;; tokenizer
(defclass mecab-tokenizer (montezuma::tokenizer)
  ((tokens :initform :unbound)
   (position :initform 0)))

(defmethod montezuma::next-token :before ((self mecab-tokenizer))
  (with-slots (montezuma::input tokens) self
    (when (eq tokens :unbound)
      (setf tokens
            (typecase montezuma::input
              (stream
               (mecab (collect 'string (scan-stream montezuma::input #'read-char))))
              (t
               (mecab montezuma::input)))))))

(defmethod montezuma::next-token ((self mecab-tokenizer))
  (with-slots (tokens position) self
    (let ((token (pop tokens)))
      (if token
          (let* ((表層形 (node-表層形 token))
                 (new-position (+ position (length 表層形)))
                 (token (or (node-原形 token) 表層形)))
            (prog1 (montezuma::make-token
                    (montezuma::normalize self token)
                    position new-position)
              (setf position new-position)))
          nil))))

(defmethod montezuma::normalize ((self mecab-tokenizer) str)
  str)

(defun search-full-text (query)
  (collect
      (montezuma:document-value
       (montezuma:get-document
        *index*
        (montezuma:doc
         (scan (montezuma::score-docs
                (montezuma:search *index* (format nil "text:~a" query)
                                  :num-docs 5000)))))
       "id")))
;;(search-full-text "京都")

(defun /search ()
  (let ((q (params :q)))
    (info.read-eval-print.web-server::make-response
     (if q
         (search-full-text q)
         ""))))

(defun search-by-id (id)
  (montezuma:search-each *index* (format nil "id:~a" id)
                         (lambda (doc score)
                           (declare (ignore score))
                           (print doc)
                           (return-from search-by-id doc)))
  nil)

(defun add-index (id text)
  (let ((doc-num (search-by-id id)))
    (if doc-num
        (montezuma:update *index* doc-num `(("text" . ,text)))
        (montezuma:add-document-to-index
         *index*
         `(("id" . ,id)
           ("text" . ,text))))
    (info.read-eval-print.web-server::make-response "ok")))

(defun /add ()
  (let ((id (params :id))
         (text (params :text)))
    (add-index id text)
    (info.read-eval-print.web-server::make-response "ok")))

(defun run ()
  (sb-thread:make-thread (lambda ()
                           (let ((*handler-package* :fts))
                             (start)))
                         :name "full text search"))


;;; analyzer
(defclass mecab-analyzer (montezuma::standard-analyzer)
  ())

(defmethod montezuma::token-stream ((self mecab-analyzer) field string-or-stream)
  (declare (ignore field))
  (reduce (lambda (acc x) (make-instance x :input acc))
          '(mecab-tokenizer
            montezuma::lowercase-filter
            montezuma::stop-filter)
          :initial-value string-or-stream))



;;; index 作成
(defparameter *index*
  (make-instance 'montezuma:index
                 :path "/tmp/montezuma" ; 指定しなければインメモリになる
                 :analyzer (make-instance 'mecab-analyzer)))


(defun make-initial-index ()
  (progn
    (clsql-sys:connect '("localhost" "outing_development" "root" "")
                       :database-type :mysql)
    (clsql-sys:execute-command "set names utf8"))
  (time
   (clsql:loop for (id name kana description address search-keyword prefecture-id)
           being the tuples of
         "select id name, kana, description, address, search_keyword, prefecture_id
from facilities"
         for text = (delete #\return (format nil "~@{~a~^ ~}" name kana description address search-keyword))
         do (print id)
         do (add-index id text))))


#|
http://localhost:8888/add?id=1&text=京都に行こう。
http://localhost:8888/add?id=2&text=東京都に行こう。
http://localhost:8888/add?id=3&text=京都府に行こう。
http://localhost:8888/search?q=京都

(time (labels ((f (q)
                 (cons q (search-full-text q))))
        (dotimes (i 100)
          (collect (f (scan '("京都" "東都" "京" "都" "子供")))))))

|#

Series でネストしたループはどう書けばいいんだろう

例えば次のようなのを Series ではどう書けばいいんだろう。

(loop for i in '(100 200 300)
      nconc (loop for j in '(10 20 30)
                  nconc (loop for k in '(1 2 3)
                              collect (+ i j k))))
;;=> (111 112 113 121 122 123 131 132 133 211 212 213 221 222 223 231 232 233 311
;;    312 313 321 322 323 331 332 333)

SERIES::*SERIES-IMPLICIT-MAP* を t にしているので、次のように書けるかと思ったがだめだった。

(collect-nconc
 (let ((x (scan '(100 200 300))))
   (collect-nconc
    (let ((y (scan '(10 20 30))))
      (collect (+ x y (scan '(1 2 3))))))))

素直に mapping で書けば動く。

(collect-nconc (mapping ((i (scan '(100 20 300))))
                 (collect-nconc (mapping ((j (scan '(10 20 30))))
                                  (collect (mapping ((k (scan '(1 2 3))))
                                             (+ i j k)))))))

しかし、どうしても implicit map で書きたい。

labels を使ってみた。動いた。可読性は。。。でも implicit map だ。

(labels ((f (x)
           (collect-nconc (ff x (scan '(10 20 30)))))
         (ff (x y)
           (collect (+ x y (scan '(1 2 3))))))
  (collect-nconc (f (scan '(100 200 300)))))

次のような感じでネストを指定できたらいいかもしれない。

(collect (+ (scan '(100 200 300))
            (#2Lscan '(10 20 30))
            (#3Lscan '(1 2 3))))

プログラミングコンテストチャレンジブック 第2版 1-6 Ants

「1-6 Ants」

今回のは Series っぽく書けた。 :IMPLICIT-MAP T してあるので明示的にループやマップを書かなくてもいい。

;;;; 1-6 Ants
(let ((l 10)
      (xs (scan '(2 6 7))))
  (values
   (collect-max (min xs (- l xs)))
   (collect-max (max xs (- l xs)))))

ThinkPad X220 を買った

ヤーンのいない暮らしの中、気をまぎらわすために ThinkPad X220 を買った。

Dell の 17 インチノート Inspiron 1720 を背負っての通勤に疲れたとう理由もあるが。今週二日自宅勤務なので ThinkPad X220 自宅用で、Inspiron 1720 は職場用にする。通勤が楽になった。

Inspiron 1720 と同様 ThinkPad X220 にも Debian sid をインストールした。正確には http://d-i.debian.org/daily-images/amd64/daily/netboot/netboot.tar.gz をインストールして sid に dist-upgrade した。 tftp から何の問題もなくネットワークインストールできた。

トラックポイントでのスクロールは gpointing-device-settings で ok なはずだが gnome3 になって(?)動かなくなったらしく、設定ファイルを書く必要があった。http://d.hatena.ne.jp/torazuka/20110611/scroll を参照。

起動時にワーニングが出るので sudo apt-get install firmware-intelwimax した。

やっぱり ThinkPad の X シリーズはいいな。 X20 以来なんだが、X20 のキーボードの方がよかったな。それだけが残念なところ。

OS は Debian sid が至高だと思う。 OS のアップグレードという無駄な作業なしに、常に最新の環境を使い続けられるから。

プログラミングコンテストチャレンジブック 第2版

ヤーンが死んでから1ヵ月以上経つが、ずっと無気力傾向にある。

そんななか近所の本屋さんブックスキタミに行ったら「プログラミングコンテストチャレンジブック 第2版」を見つけた。失礼ながらその本屋にまさかそんな本があるとは思っていなかった。買った。キタミ見直した。

どうも無気力なので、「プログラミングコンテストチャレンジブック」の例題を Series で解いてステップをとりもどしていきたいと思う。

パッケージは次のとおり。 info.read-eval-print.series-ext は https://github.com/quek/info.read-eval-print.series-ext

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :info.read-eval-print.series-ext))

(info.read-eval-print.series-ext:sdefpackage
 :programming-contest-charenge-book
 (:use :cl))

(in-package :programming-contest-charenge-book)

info.read-eval-print.series-ext:sdefpackage は (SERIES::INSTALL :PKG :PROGRAMMING-CONTEST-CHARENGE-BOOK :IMPLICIT-MAP T) をパッケージ宣言と同時に行いたがためのもの。 Series は是非とも :IMPLICIT-MAP T にすべき。

最初は「1-6 三角形」。

;;;; 1-6 三角形
(let ((a '(2 3 4 5 10)))
  (let ((ans 0))
    (iterate ((xs (scan-sublists a)))
      (iterate ((ys (scan-sublists (cdr xs))))
        (iterate ((z (scan (cdr ys))))
          (let* ((x (car xs))
                 (y (car ys))
                 (sum (+ x y z))
                 (max (max x y z)))
            (if (< max (- sum max))
                (setf ans (max ans sum)))))))
    ans))

全然 Series をいかせてない。もっとうまく書けないものか。

ヤーン

1月6日、家族みんなでヤーンの最後を看取った。仕事から帰ると迎えに出て来てくれるのはヤーンだった。

咬むの好きというより、むしろ咬まずにはいられないらしく、油断してると目をまん丸にして一番やわらかい二の腕の裏を狙って噛みついてくる。噛みついたうえに捻るものだからかなり痛かったよ。

遊んで欲しいときは猫じゃらしをくわえてやってきて、ちょとそこじゃ届かないよという場所に猫じゃらしを置く。うまく猫じゃらしを動かしてやるとぐるぐる走り回る。おいかけっこと待ち伏せも大好き。

ブルーポイントのシャム。

10年ほど前に横浜から埼玉まで車を走らせて迎えに行った。

ヤーンポッチナズムナイルピネロピルニャール卿バッハナスカレシン。

綺麗な猫。綺麗な青い目。

ニクキュウは小豆色で太陽の匂いじゃなくて苦い匂いがする。お耳はベルベットの様な毛並み。耳の後ろの毛はとてもやわらか。ふわふわ。

お風呂からあがるのを洗濯機の上で待っていて、背中をペンペン叩いてもらう。

寂しがりやで、人恋しいたちで、一人家に置いていかれた日にはいつもすごく文句を言っていた。

よくひざにのってた。ひざに Kinesis をのっけてても無理やりのってきてキーボードを打つ手首の上にあごをのせる。

1月9日、ヤーンのお葬式。

とてもいい天気。綺麗な青い空。綺麗な白い骨。

いいこのヤーンポチナ。

ぽちぽち、やんぽち。

ぽちぽち、やんぽち

昨日の続き (Common Lisp の IOLib でとても簡単な Web サーバを書く)

一年の最後に書くのも最初に書くのも Common Lisp でありたい。

Common Lisp の IOLib でとても簡単な Web サーバを書く。昨日との違いはコンパイラマクロを入れ、コンパイラが note をはからないように適当に最適化したたくらい。

ab してみる。マシンは Intel(R) Core(TM)2 Duo CPU T7100 @ 1.80GHz で。何もしないと秒間 4,000 リクエスト以上さばけるんだ。なんとなく Rails の遅さと nginx の速さに納得した。

ところで、受信イベントが2回発生し、2回目の receive-from は 0 バイトになる。そういうものなんだろうか?

outis:~% /usr/bin/ab -n 10000 -c 10 'http://localhost:8888/hello'
This is ApacheBench, Version 2.3 <$Revision: 655654 $>
Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/
Licensed to The Apache Software Foundation, http://www.apache.org/

Benchmarking localhost (be patient)
Completed 1000 requests
Completed 2000 requests
Completed 3000 requests
Completed 4000 requests
Completed 5000 requests
Completed 6000 requests
Completed 7000 requests
Completed 8000 requests
Completed 9000 requests
Completed 10000 requests
Finished 10000 requests


Server Software:
Server Hostname:        localhost
Server Port:            8888

Document Path:          /hello
Document Length:        40 bytes

Concurrency Level:      10
Time taken for tests:   2.282 seconds
Complete requests:      10000
Failed requests:        0
Write errors:           0
Total transferred:      970000 bytes
HTML transferred:       400000 bytes
Requests per second:    4382.89 [#/sec] (mean)
Time per request:       2.282 [ms] (mean)
Time per request:       0.228 [ms] (mean, across all concurrent requests)
Transfer rate:          415.18 [Kbytes/sec] received

Connection Times (ms)
              min  mean[+/-sd] median   max
Connect:        0    0  17.3      0    1002
Processing:     0    1  21.4      1    1380
Waiting:        0    1  21.4      1    1380
Total:          0    2  27.5      1    1380

Percentage of the requests served within a certain time (ms)
  50%      1
  66%      1
  75%      1
  80%      1
  90%      2
  95%      3
  98%      4
  99%      5
 100%   1380 (longest request)

#+nil
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :iolib)
  (ql:quickload :quek))

(quek:sdefpackage :httpd
                  (:use :cl))

(in-package :httpd)

(named-readtables:in-readtable quek:|#"|)

(defvar *httpd*)

(alexandria:define-constant +crlf+ (format nil "~c~c" #\cr #\lf) :test #'equalp)

(defun start (&key (port 8888))
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (setf *httpd* (make-instance 'iolib.multiplex:event-base))
  (let ((socket (iolib.sockets:make-socket :address-family :ipv4
                                           :type :stream
                                           :connect :passive
                                           :local-host "0.0.0.0"
                                           :local-port port
                                           :reuse-address t)))
    (iolib.sockets::listen-on socket)
    (describe socket)
    (iolib.multiplex::set-io-handler
     *httpd*
     (iolib.streams::fd-of socket)
     :read (lambda (fd event exception)
             (declare (ignore fd event exception))
             (let* ((client-socket (iolib.sockets:accept-connection socket))
                    (fd (iolib.streams:fd-of client-socket)))
               (iolib.multiplex:set-io-handler
                *httpd* fd
                :read (lambda (_fd event exception)
                        (declare (ignore _fd event exception))
                        (unwind-protect
                             (handler client-socket)
                          (iomux:remove-fd-handlers *httpd* fd)
                          (close client-socket)))))))
    (unwind-protect
         (iolib.multiplex:event-dispatch *httpd*)
      (close socket))))

(defun handler (client-socket)
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
    (declare (dynamic-extent buffer))
    (multiple-value-bind (buffer nbytes) (iolib.sockets:receive-from client-socket :buffer buffer)
      (declare (type fixnum nbytes))
      ;; イベントが2回発生し、2回目の receive-from は 0 バイトになる。そういうもの?
      (when (plusp nbytes)
          (multiple-value-bind (buffer nbytes) (request buffer nbytes)
            (iolib.sockets:send-to client-socket buffer :end nbytes))))))

(defun request (buffer nbytes)
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type (simple-array (unsigned-byte 8)) buffer))
  (let* ((start (position #x20 buffer :end nbytes))
         (end (position #x20 buffer :start (+ start 2) :end nbytes))
         (path (sb-ext:octets-to-string buffer
                                        :external-format :utf-8
                                        :start (1+ start)
                                        :end end))
         (symbol-name (prog1 (string-upcase path)
                        #|(format t "~&~a" path)|#))
         (symbol (or (find-symbol symbol-name :httpd) '/404)))
    (funcall (symbol-function symbol))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-response (content)
    (declare (optimize (speed 3) (safety 0) (debug 0)))
    (let* ((response #"""HTTP/1.0 200#,+crlf+,Content-Type: text/html; charset=utf-8;#,+crlf+,#,+crlf+,#,content""")
           (buffer (sb-ext:string-to-octets response :external-format :utf-8)))
      (declare (type (simple-array (unsigned-byte 8)) buffer))
      (values buffer (length buffer)))))

(define-compiler-macro make-response (&whole form content &environment env)
  (if (constantp content env)
      (multiple-value-bind (buffer nbytes) (make-response content)
        `(values ,buffer ,nbytes))
      form))

(defun /hello ()
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (make-response "<html><body><h1>hello</h1></body></html>"))

(defun /404 ()
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (make-response "<html><body><h1>404</h1></body></html>"))