2011/11/20

Node.js っておもしろそうなので

Common Lisp でエコーサーバが書けるまで実装してみた。

#+nil
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :iolib)
(ql:quickload :hu.dwim.defclass-star)
(ql:quickload :anaphora)
(ql:quickload :quek))


(quek:sdefpackage :node.cl
(:use :cl :quek :anaphora)
(:import-from :hu.dwim.defclass-star #:defclass*)
(:shadow #:close
#:listen
#:stream
#:write
#:read)
(:export #:serever))

(in-package :node.cl)

(defvar *event-base* nil)

(defmacro with-event-base (&body body)
`(let ((*event-base* (make-instance 'iolib.multiplex:event-base)))
,@body
(iolib.multiplex:event-dispatch *event-base*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; event

(defclass* event-emitter ()
((max-listeners 10)
(events (make-hash-table))))

(defmethod emit ((event-emitter event-emitter) type &rest args)
(awhen (gethash type (events-of event-emitter))
(iterate ((f (scan (gethash type (events-of event-emitter)))))
(apply f args))))

(defmethod on ((event-emitter event-emitter) type listener)
(push listener (gethash type (events-of event-emitter))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; handle

(defclass* handle (event-emitter)
((handle)))

(defmethod close ((handle handle))
(on-close handle))

(defmethod on-close ((handle handle))
(dispose (handle-of handle))
(clear (handle-of handle)))

(defmethod dispose (x))
(defmethod clear (x))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; stream

(defclass* stream (handle)
((on-read)
(external-format :utf-8)
(buffer (make-array 1024 :element-type 'iolib.base:ub8))))

(defmethod read-start ((stream stream))
(iolib.multiplex:set-io-handler
*event-base*
(iolib.streams:fd-of (handle-of stream))
:read (lambda (fd event exception)
(declare (ignore fd event exception))
(on-read stream))))

(defmethod read-stop ((stream stream))
(iolib.multiplex:remove-fd-handlers *event-base*
(iolib.streams:fd-of (handle-of stream))
:read t))

(defmethod on-read ((stream stream))
(multiple-value-bind (buffer nread) (iolib.sockets:receive-from (handle-of stream)
:buffer (buffer-of stream)
:start 0
:end (length (buffer-of stream)))
(funcall (on-read-of stream) buffer 0 nread)))

(defgeneric write (stream buffer &rest args &key &allow-other-keys))

(defmethod write (x buffer &key)
(iolib.sockets:send-to x buffer))

(defmethod write ((handle handle) buffer &key)
(write (handle-of handle) buffer))

(defmethod write ((stream stream) (buffer string) &key)
(write (handle-of stream)
(sb-ext:string-to-octets buffer :external-format (external-format-of stream))))


(defmethod pipe ((stream stream) dest &rest options)
(declare (ignore options))
(on stream :data (lambda (chunk)
(write dest chunk))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; TCP

(defclass* tcp (stream)
((on-connection)))

(defmethod initialize-instance :after ((tcp tcp) &key port ip)
(when (and port ip)
(setf (handle-of tcp) (iolib.sockets:make-socket :address-family :ipv4
:connect :passive
:external-format :utf-8
:local-host ip
:local-port port))))

(defgeneric listen (x &key &allow-other-keys))

(defmethod listen ((tcp tcp) &key)
(iolib.sockets:listen-on (handle-of tcp))
(iolib.multiplex:set-io-handler
*event-base*
(iolib.streams:fd-of (handle-of tcp))
:read (lambda (fd event exception)
(declare (ignore fd event exception))
(on-connect tcp (handle-of tcp)))))

(defmethod on-connect ((tcp tcp) handle)
(let ((client (make-instance 'tcp :handle (iolib.sockets:accept-connection (handle-of tcp)))))
(funcall (on-connection-of tcp) client)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; socket

(defclass* socket (stream)
((server)))

(defmethod initialize-instance :after ((socket socket) &key handle)
(when handle
(setf (on-read-of handle)
(lambda (buffer offset length)
(emit socket :data
(sb-ext:octets-to-string buffer :external-format (external-format-of socket)
:start offset
:end (+ offset length)))))))

(defmethod resume ((socket socket))
(read-start (handle-of socket)))

(defmethod pause ((socket socket))
(read-stop (handle-of socket)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; serever

(defclass* server (event-emitter)
((connections)
(handle)))

(defmethod initialize-instance :after ((server server) &key connection)
(on server :connection connection))

(defmethod listen ((server server) &key port ip)
(with-slots (handle) server
(setf handle (make-instance 'tcp :port port :ip ip))
(setf (on-connection-of handle)
(lambda (client-handle)
(let ((socket (make-instance 'socket :handle client-handle
:server server)))
(resume socket)
(emit server :connection socket)
(emit socket :connect))))
(listen handle)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; echo server

#|
var net = require('net');
var server = net.createServer(function (socket) {
socket.write("Echo server\r\n");
socket.pipe(socket);
});
server.listen(1337, "127.0.0.1");

(with-event-base
(let ((server (make-instance 'server
:connection (lambda (socket)
(write socket "Echo server")
(write socket #(#x0d #x0a))
(pipe socket socket)))))
(listen server :port 1111 :ip "127.0.0.1")))
|#

2011/11/18

CLOS の引数の数が違うメソッド

CLOS だと (defmethod bar ()) (defmethod bar (x)) のように引数の数が違うメソッドを定義することができない。

でも、こんなふうにすれば、できなくもない。 &key とか &optional とかは考慮してない。

(defmacro dm (name args &body body)
`(progn
(unless (fboundp ',name)
(defun ,name (&rest args)
(apply (intern (format nil ,(format nil "~a/~~d" name) (length args)))
args)))
(defmethod ,(intern (format nil "~a/~d" name (length args))) ,args
,@body)))

(dm foo ((a string))
(length a))

(dm foo ((n number))
(* n n n))

(dm foo ()
"empty")

(dm foo (a b c)
(list a b c))

(list
(foo "abc")
(foo 3)
(foo)
(foo 1 2 3))
;;=> (3 27 "empty" (1 2 3))

2011/11/06

rsync と Btrfs のスナップショットでバップアップ

参考

~/bin/backup-home.sh

#!/bin/bash

# 準備
# sudo btrfs subvolume create /backup/home
# sudo chown ancient:ancient /backup/home
# sudo mkdir /backup/home-snapshot
# sudo chown ancient:ancient /backup/home-snapshot
#
# 消す時はこう。rm では消えない。
# sudo btrfs subvolume list /backup
# sudo btrfs subvolume delete /backup/home-snapshot/20111106-014626
# sudo btrfs subvolume list /backup

# rsync して、スナップショットをとる。
nice -n 19 rsync -auv --delete --exclude '*~' --exclude '*.fasl' --exclude '*.log' --exclude 'ancient/.cache' $HOME /backup/home && /sbin/btrfs subvolume snapshot /backup/home /backup/home-snapshot/`date +%Y%m%d-%H%M%S`

/etc/fstab

# /etc/fstab: static file system information.
#
# <file system> <mount point> <type> <options> <dump> <pass>
proc /proc proc defaults 0 0
# /dev/sda1 / ext3 defaults,errors=remount-ro 0 1
UUID=3b2f3a35-9633-4904-9a2b-3c9b13cc41be / ext3 defaults,errors=remount-ro 0 1
# /dev/sda5 none swap sw 0 0
UUID=ac69103d-7296-453a-b4ee-a4b52c7176f4 none swap sw 0 0
# /dev/hda /media/cdrom0 udf,iso9660 user,noauto 0 0
/dev/cdrom1 /media/cdrom0 udf,iso9660 user,noauto 0 0
# usb disk
UUID=b20c3f2a-37e0-47ac-96df-3051d30f917a /backup btrfs defaults,noauto,user,compress 0 0
outis:~% mount /backup
outis:~% ~/bin/backup-home.sh