仙石浩明CTO の日記: プログラミングと開発環境

プログラミングと開発環境

2007年01月22日

Perl の非同期I/Oモジュール POE を使って VPN-Warp relayagent を書いてみました

多数の TCP/IP セッションを同時に維持する必要性などから、非同期I/O が最近流行りのようです。何をいまさら、という気もするのですが、いわゆる「最新技術」の多くが 30年前の技術の焼き直しに過ぎない今日このごろなので、非同期I/O 技術が「再発見」されるのも、「歴史は繰り返す」の一環なのでしょう。スレッドが当たり前の時代になってからコンピュータ技術を学んだ人にとっては、 (古めかしい) 非同期I/O が新鮮に映るのかも知れず、なんだか「ファッションのリバイバル」に似ていますね。

Perl で非同期I/O 処理を手軽に行なうための枠組みとして、 POE: Perl Object Environment というものがあるようです。 POE を使うと、あたかもスレッドを使っているような手軽さでプログラミングできます。試しに VPN-Warp の relayagent を POE を使って書いてみました。オリジナルの relayagent は C 言語で記述した 4000 行を超えるプログラムなのですが、 Perl だと 200 行以下で一通り動くものが書けてしまいました (もちろん C 版の機能を全て実装したわけではありません)。

POE を触るのは今回が初めてだったので、マニュアルをいちいち参照しながら書いたのですが、なにせわずか 200 行ですから、開発はデバッグ込みで 1 日かかりませんでした。改めて Perl の記述性の良さと開発効率の高さに感動したのですが、これだけ簡潔に書けてしまうと、 relayagent の機能を解説するときの教材としても使えそうです。

というわけで、今までブラックボックスだった relayagent の中身の解説を試みたいと思います。これから POE を使ってみようとする人の参考にもなれば幸いです。

VPN-Warp の relayagent とは、以下の図のようにリレーサーバと Webサーバの両方へ接続して、リレーサーバから受取ったリクエストを Webサーバへ中継するプログラムです。 http リクエストを受取ってサービスを行なうのですから、サーバの一種と言えますが、外部から接続を受付けるわけではなく、リレーサーバと Webサーバの両方に対してクライアントとして振る舞う点がユニークと言えるでしょう。

                      リレー            イントラ         イントラ
ブラウザ ─────→ サーバ ←──── relayagent──→ Webサーバ
            https     443番ポート                        80番ポート

http リクエストを受取って Webサーバへ中継するプログラムというと、 proxy サーバを思い浮かべるかも知れません。 proxy サーバはその名の通り、ブラウザに対してはサーバとして振る舞います:

                                        proxy            イントラ
ブラウザ ──────────────→ サーバ────→ Webサーバ
                                        8080番ポート     80番ポート

proxy サーバが、ブラウザからの接続を受付けて、それを Webサーバに中継するのに対し、 relayagent は自身では接続を受付けずに中継する、という違いがお分かりでしょうか？ relayagent は接続を受ける必要がないため、ファイアウォールの内側など、外部からアクセスできない場所で使うことが可能になっています。

なお、C 版の relayagent はリレーサーバに対して https で接続するのですが、 Perl 版 relayagent (以下 relayagent.pl) は、説明の都合上 SSL 暗号化の機能を含んでいません。実際に使うときは、 stone などで SSL 暗号化してリレーサーバに接続する必要があります。

         リレー                         イントラ         イントラ
         サーバ ←──── stone ←── relayagent──→ Webサーバ
         443番ポート       SSL化        Perl 版          80番ポート

例えば stone を

stone -q pfx=relay,5000005.pfx \
      -q passfile=relay,5000005-pass.txt \
      warp.klab.org:443/ssl localhost:12345 &

などと実行しておき、 relayagent.pl はリレーサーバに接続する代わりに、 localhost の 12345 番に接続します。

では、relayagent.pl を順に見ていきましょう。

#!/usr/bin/perl
use POE qw(Component::Client::TCP Filter::Stream);
my $IdleTimerMax = 6;	# 60 sec
&help unless @ARGV == 2;
&help unless shift =~ m/^(\w+):(\d+)$/;
my ($RelayHost, $RelayPort) = ($1, $2);
&help unless shift =~ m/^(\w+):(\d+)$/;
my ($WebHost, $WebPort) = ($1, $2);
my %WebHeap;
my $PollBuf;
my $PollHeap;
my $PollHeader;
my $IdleTimer;
my $DisconectTime = 0;

$RelayHost, $RelayPort は、リレーサーバのホスト名とポート番号ですが、
前述したように stone 経由でリレーサーバにつなぐために、
$RelayHost = "localhost", $RelayPort = 12345 などとなります。また、 $WebHost, $WebPort は、中継先となる (イントラの) Webサーバのホスト名とポート番号です。

続いて、リレーサーバへ接続する (直接の接続先は SSL 化を行なう stone ですが、煩雑になるので以下「リレーサーバ」と略記します) ためのコードです:

POE::Component::Client::TCP->new
    ( RemoteAddress => $RelayHost,
      RemotePort    => $RelayPort,
      Connected     => sub {
	  $PollHeap = $_[HEAP];
	  undef $PollHeader;
	  $PollBuf = "";
	  $IdleTimer = $IdleTimerMax;
	  $PollHeap->{server}->
	      put("GET /KLAB/poll HTTP/1.1\r\nX-Ver: realyagent.pl 0.01\r\n\r\n");
      },
      ServerInput   => sub {
	  $PollHeap = $_[HEAP];
	  $PollBuf .= $_[ARG0];
	  &doPoll;
      },
      Filter        => POE::Filter::Stream->new(),
      Disconnected  => \&reconnectPoll,
    );

POE では、非同期に動く処理を、処理ごとに分けて書くことができます。各処理のことを「POEセッション」と呼びます。

上記は、リレーサーバへ接続する POEセッションの生成です。接続先ホストおよびポートを、それぞれ $RelayHost と $RelayPort に設定しています。

「Connected => sub {」から始まる部分が、接続に成功したときに実行するコードです。細かいところはさておき、接続したら以下のリクエストをリレーサーバに送る、という点は読み取れるのではないでしょうか。

GET /KLAB/poll HTTP/1.1
X-Ver: realyagent.pl 0.01

同様に、「ServerInput => sub {」から始まる部分が、通信相手 (リレーサーバ) からデータを受信したときに実行するコードです。受信したデータは、いったん変数 $PollBuf に溜めておいて、続いて呼び出す doPoll の中で処理を行ないます。

以上からお分かりのように、リレーサーバへデータを送るときは、
「$PollHeap->{server}->put(送るべきデータ);」を実行し、リレーサーバからデータが送られてきた時は、 doPoll で受取ります。とても見通しが良いですね。

各 POEセッションは、スレッドと同様、同一メモリ空間を共有しているので、他の POEセッションが変更した変数の値を参照できます。したがってどの POEセッションでもリレーサーバへデータを送ることができますし、リレーサーバから受信したデータはどの POEセッションでも読むことができます。

続いて、もう一つ POEセッションを作ります。

POE::Session->create
    ( inline_states =>
      { _start => sub {
	  $_[KERNEL]->delay( tick => 10 );
        },
        tick => sub {
	    if ($IdleTimer > 0) {
		if (--$IdleTimer <= 0) {
		    &sendControl(0, -2);	# keep alive
		}
	    }
            $_[KERNEL]->delay( tick => 10 );
        },
      },
    );
$poe_kernel->run;
exit;

この POEセッションは 10秒に一回、「tick => sub {」から始まる部分を実行します。見ての通り、$IdleTimer の値を減らしていって、 0 になったら sendControl を実行します。 $IdleTimer は最初 6 ($IdleTimerMax) に設定されるので、 1 分ごとに sendControl を実行する、という意味ですね。

以上 2つの POEセッションは作成しただけで、まだ走り出していません。
その次の「$poe_kernel->run;」が各 POEセッションを走らせるための呼び出しです。このルーチンは全ての POEセッションが終了するまで返ってきません。

さて、relayagent はリレーサーバとの接続を常時維持していますが、無通信時間が続くと (通信経路中にあるファイアウォールなどに) 切られてしまう恐れがあるので、 keep alive ブロックを送信しています。通信が行なわれていない時間を測るためのカウンタが $IdleTimer というわけです。

通信が行なわれない限り $IdleTimer は減り続け、 1 分経過すると sendControl(0, -2) を呼び出して keep alive ブロックを送信します。 sendControl はこんな感じ:

sub sendControl {
    my ($id, $control) = @_;
    $control += 65536 if $control < 0;
    $IdleTimer = $IdleTimerMax;
    if (defined $PollHeap && $PollHeap->{connected}) {
	$PollHeap->{server}->put(pack("nn", $id, $control));
    }
}

既に説明したように「$PollHeap->{server}->put(データ)」は、リレーサーバにデータを送る呼び出しですから、「pack("nn", 0, 65534)」が keep alive ブロックであることが分かります。

「ブロック」というのは VPN-Warp 用語でして、 relayagent とリレーサーバとの通信は、基本的にこの「ブロック」を単位にして行ないます。ブロックは次のような可変長のデータです。

    ┌───┬───┬───┬───┬───┬─≪─┬───┐
    │セッションＩＤ│　データ長　　│　　可変長データ　　　│
    └───┴───┴───┴───┴───┴─≫─┴───┘
          2バイト         2バイト      「データ長」バイト

「セッションID」および「データ長」は、ビッグエンディアンです。つまり上位バイトが先に来ます。データ長が 0 ないし負数の場合は、「可変長データ」の部分は 0 バイトになります。

データ長が 0 ないし負数であるブロックは、コントロール用のブロックで、以下の意味を持っています:

データ長	意味	内容
0	EOF	Webセッションの終了を要求
-1	Error	Webセッションの異常終了を要求
-2	Keep Alive	無通信状態が続いたときに送信
-3	X OFF	Webセッションのデータ送信の一時停止を要求
-4	X ON	Webセッションのデータ送信の再開を要求

ブラウザ送ったリクエストを Webサーバに届け、 Webサーバのレスポンスをブラウザに返す一連の通信のことを、ここでは「Webセッション」と呼ぶことにします。つまり、 VPN-Warp が提供する仮想的な通信路 (トンネル) 上のセッションです。

ブラウザがリレーサーバと通信するときの TCP/IPセッションと、 relayagent と Webサーバが通信するときの TCP/IPセッションを対応づけるのが、セッションID です。「セッション」という言葉が何度も出てきてややこしいですが、「セッションID」の「セッション」は、「Webセッション」の意味です。

リレーサーバと relayagent との間は、複数の Webセッションを一本の TCP/IPセッションに相乗りさせるので、そのとき各 WebセッションがこんがらないようにするためにブロックにはセッションID がつけられている、というわけです。

では、次はいよいよ relayagent の中核ルーチンである doPoll です:

sub doPoll {
    do {
	if (! defined $PollHeader) {
	    if ($PollBuf =~ /\r\n\r\n/) {
		$PollHeader = $`;
		$PollBuf = $';
	    }
	}
	return unless defined $PollHeader;
	my ($id, $len, $data) = unpack("nna*", $PollBuf);
	return unless defined $id && defined $len && $len ne "";
	if ($len > 32767) {
	    $len -= 65536;
	    $PollBuf = $data;
	    if ($len == -1) {
		&closeWeb($id);
	    }
	} elsif ($len > 0) {
	    return unless defined $data && length($data) >= $len;
	    ($data, $PollBuf) = unpack "a${len}a*", $data;
	    &reqWeb($id, $data);
	} else {	# len == 0
	    $PollBuf = $data;
	    &closeWeb($id);
	}
    } while ($PollBuf);
}

前述したように、relayagent はリレーサーバに接続したとき、まず
「GET /KLAB/poll HTTP/1.1」から始まるリクエストヘッダを送ります。するとリレーサーバは、次のようなレスポンスを返します:

HTTP/1.1 200 OK
X-Customer: nusers=5&type=1&expire=1169696110&digest=3f6977eceb8c2c43e28e6026b08ba900

そしてこの後 (doPoll において「defined $PollHeader」が真のとき)、リレーサーバと relayagent は、前述したブロックを送受信することになります。

「my ($id, $len, $data) = unpack("nna*", $PollBuf);」の部分が、
リレーサーバから受信したブロックを、
「セッションID ($id)」「データ長 ($len)」「可変長データ ($data)」に分解している処理ですね。続いてブロックの処理が行なわれますが、コントロールブロックに関する処理は割愛して、可変長データが付いているブロックの処理を見ていきましょう。ここで受信した可変長データは、ブラウザが送信した http リクエストを 2048バイトごとに分割したものです。

つまりリレーサーバは、ブラウザから https リクエストを受取るたびに「セッションID」を割り振ります。そして、リクエストをブロックに分割して relayagent へ送信し、逆に relayagent から受取ったブロックを同じセッションID ごとに連結して、 http レスポンスとしてブラウザへ送信します。

したがって、 relayagent はリレーサーバから受取ったブロックを同じセッションID ごとに連結して Webサーバへ中継し、そのレスポンスをブロックに分割してリレーサーバへ送信すればよいことになります。

同じセッションID ごとに連結して Webサーバへ送信する処理が、 reqWeb です:

sub reqWeb {
    my ($id, $req) = @_;
    if (defined $WebHeap{$id} && $WebHeap{$id}->{connected}) {
	$WebHeap{$id}->{server}->put($req);
    } else {
	POE::Component::Client::TCP->new
	    ( RemoteAddress => $WebHost,
	      RemotePort    => $WebPort,
	      Connected     => sub {
		  $WebHeap{$id} = $_[HEAP];
		  $WebHeap{$id}->{server}->put($req);
	      },
	      ServerInput   => sub {
		  $WebHeap{$id} = $_[HEAP];
		  &sendRes($id, $_[ARG0]);
	      },
	      Filter        => POE::Filter::Stream->new(),
	      Disconnected  => sub {
		  &sendControl($id, 0);
	      },
	    );
    }
}

「POE::Component::Client::TCP->new」によって、 Webサーバと通信するための POEセッションを生成しています。この reqWeb を実行しているのは、リレーサーバとの通信を受け持つ POEセッションでしたが、この POEセッションが新たに POEセッションを生成している点に注意してください。

新しく生成した POEセッションは、Webサーバと接続したとき (Connected)、
「$WebHeap{$id}->{server}->put($req);」を実行してリクエスト ($req) を Webサーバに送信します。そして Webサーバからレスポンスを受信したとき (ServerInput)、 sendRes を実行します。

sub sendRes {
    my ($id, $res) = @_;
    $IdleTimer = $IdleTimerMax;
    if (defined $PollHeap && $PollHeap->{connected}) {
	for my $block (unpack "(a2048)*", $res) {
	    $PollHeap->{server}->
		put(pack("nna*", $id, length($block), $block));
	}
    }
}

sendRes は Webサーバからのレスポンス ($res) を 2048バイトごとに分割し、セッションID ($id) とデータ長 (length($block)) を付加したブロックとしてリレーサーバに送信します。

以上をまとめたのが、relayagent スクリプトです。ここで解説した機能の他、 http リクエストヘッダの Host: フィールドを書き換える機能も追加しています。

C 版の relayagent に比べると、 http レスポンスの書き換え機能や、 http 以外のプロトコルを通す機能などがない点や、高負荷時の性能の検証が充分行なえていない点など、そのまま実運用に使用するには難しい点もありそうですが、少なくともプロトタイピングなどの目的 (あるいは教育などの目的) ならば充分使えそうです。

hiroaki_sengoku at 07:13｜この記事のURL │Comments(0) │TrackBack(0)

2006年05月08日

Emacsでtrampを使って /su:root@localhost:/ をアクセスする

先日書いた「su & emacsclient」にトラックバックを頂きました (_O_)。曰く:

tramp は /su: や /sudo: なパスを扱う場合は内部で su や sudo を使うだけで、なんでもかんでも ssh を使うわけではないです。

思い切り誤解してました。orz
私の場合、su は opie 使っていて、

senri:/home/sengoku % su
otp-md5 416 se2369 ext
root's response:

などとなるので、

(setq tramp-password-prompt-regexp 
"^.*\\([pP]assword\\|passphrase.*\\|\n.*response\\):^@? *")

と設定することにより、チャレンジの部分を含めてプロンプトに出すことができて、無事 tramp & su で root 権限でファイルを編集することができました。長年(?)の懸案が解決しました(_O_)。

日記で質問してよかった～

hiroaki_sengoku at 17:49｜この記事のURL │Comments(0) │TrackBack(0)

2006年05月05日

su ＆ emacsclient

普段 emacs を使っている人に質問なのですが、
root 作業するときどうしてますか？

私は、GNU Screen の中で emacs をずーっと立ち上げっぱなしにしていて、ほとんどの作業を emacs の中で行なっています。もちろんコマンドラインから何かを実行するときも、 emacs の shell モード (正確に言うと j-shell.el なんですが ^^;) の中で行なっています。

いきおい、root になるときも shell モードで「su」を実行することになります。で、root 権限でファイルを読み書きしようとしたとき、どうするのがいいか、というのが問題です。

そんなの root で emacs を実行しておけばええやん、という声が聞こえてきそうですが、 root 権限で常に emacs が動いている、というのは想像するのもおぞましいですし、かといって編集するたびに root で emacs を立ち上げるのは、 (起動に時間がかかるので) もっと嫌です。そもそも root 権限で emacs (に限らずエディタならなんでも) を立ち上げるには、 Screen の別ウィンドウで行なわなければならず、ウィンドウの切替で作業がかなり煩雑になってしまいます。

ちなみに、ずーっと以前は、ange-ftp を使っていました。つまり、emacs から root@localhost へ ftp して (root の) ファイルを読んできて編集し、保存するときも ftp で書込む。この方法は root でログインする、という気持ち悪さがもともとあったので、 ftpd を走らせなくなったのを機会に止めました。

で、それ以来使っているのが、今回紹介する emacsclient を使う方法です。もしもっといい方法があるぞっ、というかたがいらっしゃいましたら、是非教えてください (_O_)。

- o -

emacs 上で「M-x server-start」と入力すると、 emacsserver (gnuserv) を走らせておくことができます。この状態で、コマンドラインから

% emacsclient ファイル名

などと emacsclient (gnuclient) を実行すると、引数に指定したファイルを、emacs で編集することができます。

したがって、root 権限でファイルを編集するときは、まずファイルを emacs で読み書きできるようテンポラリファイルへコピーし、それを emacsclient で開き、テンポラリファイルが変更されたら、それを元のファイルへ root 権限で書き出せばよいことになります。

私は suemacs と名付けた以下のような perl スクリプトを書いて使っています。例えば

# suemacs /root/.cshrc

などと実行すると、 /root/.cshrc の内容が /tmp/suemacs5544/.cshrc_0 へコピーされ、 emacsclient /tmp/suemacs5544/.cshrc_0が実行されます。

suemacs スクリプト

#!/usr/bin/perl
$user = $ENV{'LOGNAME'};
$tmp = "/tmp/suemacs$$";
$Debug = 0;
$Once = 0;
use POSIX ":sys_wait_h";
use Getopt::Std;
getopts('do') || &help;
$Debug = 1 if $opt_d;
$Once = 1 if $opt_o;

sub help {
    print <<EOF;
Usage: suemacs <opt> <file>...
opt:  -o        ; write once on closing
      -d        ; for debug
EOF
    exit 1;
}

if ($> != 0 || ! $user) {
    exec "emacsclient", @ARGV;
}
($login, $pass, $uid, $gid) = getpwnam($user) or die;
print "login: $login,  uid: $uid,  gid: $gid\n" if $Debug;
umask 077;
mkdir $tmp || die;
chown $uid, $gid, $tmp;

for ($i=0; $i < @ARGV; $i++) {
    my $tmpfile = $ARGV[$i];
    $tmpfile =~ s@.*/@@;
    $tmpfile = "$tmp/${tmpfile}_$i";
    push @argv, $tmpfile;
    my $mtime = &cp($ARGV[$i], 0, $tmpfile);
    push @mtime, $mtime;
    chown $uid, $gid, $tmpfile;
}
if (!$Debug) {
    if (!fork) {
	close(STDOUT);
	close(STDERR);
	open(">&STDOUT", "/dev/null") || die;
	open(">&STDERR", "/dev/null") || die;
    } else {
	exit 0;
    }
}
if (!fork) {
    ($(, $)) = ($gid, $gid);
    ($<, $>) = ($uid, $uid);
    exec "emacsclient", @argv;
    exit 0;
}
my ($ret);
do {
    sleep 1;
    $ret = waitpid(-1,WNOHANG);
    print "ret: $ret, status: $?\n" if $ret > 0 && $Debug;
    for ($i=0; $i < @argv; $i++) {
	$mtime[$i] = &cp($argv[$i], $mtime[$i], $ARGV[$i])
	    if $ret > 0 || ! $Once;
	unlink $argv[$i] if $ret > 0;
    }
} until ($ret > 0);
rmdir $tmp;
exit 0;

sub cp {
    my ($src, $stime, $dst) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	$atime,$mtime,$ctime,$blksize,$blocks) = stat($src);
    if ($stime == $mtime) {
	print "$src is not modified.\n" if $Debug;
	return $mtime;
    }
    print "cp $src $dst\n" if $Debug;
    open(SRC, $src) || die;
    open(DST, ">$dst") || die;
    while (<SRC>) {
	print DST;
    }
    close(DST);
    close(SRC);
    utime $atime, $mtime, $dst;
    return $mtime;
}

hiroaki_sengoku at 19:35｜この記事のURL │Comments(3) │TrackBack(1)

2006年05月01日

livedoor blog 生ログ取得スクリプト (2)

昨日書いた「livedoor blog 生ログ取得スクリプト」を使って、毎日前日の生ログを取得する cron を仕掛けておいたのですが、月が代わった途端に問題発覚(^^;)。 livedoor blog の生ログって、月単位なのですね。つまり、生ログを参照するページの URL は、

http://analyzer.livedoor.com/log/raw?page_id=22222&y=2006&m=4

などとなっていますが、「m=4」を指定しない限り 4月分のログは表示されない (今月分のみ表示される)、という仕様のようです。 livedoor blog の有料プランを始めてから初めての月代わりだったもので...

というわけで、生ログを取得する際に日付を指定できるように修正してみました。

livedoor.pl gcd date 2006-04-30 raw_log 100 -

などと、「date YYYY-MM-DD」ないし「date YYYY-MM」を指定することにより、生ログを取得する日付ないし月を指定できます。「raw_log 100 - 」は、生ログ 100ページ分 (2000行) を標準出力 (「 - 」) に出力する、という意味です。

生ログを遡っていく途中で、指定した日付と異なる日付の生ログが得られたら、それ以上の取得をストップするので、ページ数は多めに指定しておいて大丈夫です。また、ついでに「ブログのエクスポート（バックアップ）」もサポートしました。

livedoor.pl gcd export_reserve

で、「エクスポートファイルの作成」を行ない、

livedoor.pl gcd export バックアップファイル名

で、エクスポートファイルをダウンロードして「バックアップファイル名」で保存します。

以上の機能は、 livedoor blog の有料プランを選択していないと使用できませんが、スタイルシート（CSS）および HTMLのテンプレートの取得は、ブログのデザインを custom に設定していれば使用できます。

まず、livedoor blog の管理ページで、「カスタマイズ/管理」-「デザインの設定」を選び、デザインとして「カスタマイズ」を選択したときの URL を確認します。例えば

http://cms.blog.livedoor.com/cms/design/edit?blog_id=1600549&id=11111

といった感じの URL になると思います。「blog_id=1600549」および「id=11111」の数字を、スクリプト先頭の

"BlogID" => 1600549,
"ID"     => 11111,

の部分に設定しておいて、

livedoor.pl gcd css CSSファイル名

と実行すれば、スタイルシート(CSS) が「CSSファイル名」で保存されます。「css」の代わりに、「index_tmpl」「article_tmpl」「category_tmpl」「monthly_tmpl」を指定すれば、それぞれ「トップページ」「個別記事ページ」「カテゴリアーカイブ」「月別アーカイブ」の HTMLテンプレートを保存できます。一度のスクリプト実行で一括して保存することもできます:

livedoor.pl gcd css blog.css index_tmpl blog.html \
	article_tmpl blog_article.html \
	category_tmpl blog_category.html \
	monthly_tmpl blog_month.html

「スタイルシート(CSS)」を、「blog.css」へ、
「トップページ」を、「blog.html」へ、
「個別記事ページ」を、「blog_article.html」へ、
「カテゴリアーカイブ」を、「blog_category.html」へ、
「月別アーカイブ」を、「blog_month.html」へ、
それぞれ保存します。

livedoor.pl (livedoor blog 生ログ & CSS/テンプレート取得スクリプト)

#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Request::Common;
use CGI qw/unescapeHTML/;

%blogs = (
    "gcd" => { 
	"User"   => "hiroaki_sengoku",
	"Pass"   => "xxxxxxxx",
	"BlogID" => 1600549,
	"ID"     => 11111,
	"PageID" => 22222,
    },
    "klab" => {
	"User"   => "klab_sengoku",
	"Pass"   => "yyyyyyyy",
	"BlogID" => 1631449,
	"ID"     => 33333,
	"PageID" => 44444,
    },
);

&help unless $_ = shift;
if (exists $blogs{$_}) {
    my $blog = $blogs{$_};
    $User =   $$blog{"User"};
    $Pass =   $$blog{"Pass"};
    $BlogID = $$blog{"BlogID"};
    $ID =     $$blog{"ID"};
    $PageID = $$blog{"PageID"};
} else {
    &help;
}

$ua = new LWP::UserAgent;
$ua->agent("Mozilla/5.0 (Windows; U; Windows NT 5.1; ja)");
$ua->env_proxy();
$ua->cookie_jar( {} );
my $res = $ua->request(POST "http://member.livedoor.com/login/index",
		       [ "livedoor_id" => $User, "PASSWORD" => $Pass,
			 ".next" => "", ".sv" => "" ]);
while (my $type = shift) {
    if ($type eq "date") {
	$_ = shift;
	if (/^(\d\d\d\d)-(\d\d)(?:-(\d\d))?$/) {
	    $Year = $1;
	    $Month = ($2 + 0);
	    $Date = $_;
	} else {
	    die "date must be YYYY-MM-DD: $_\n";
	}
    } elsif ($type eq "css" ||
	     $type eq "index_tmpl" || $type eq "article_tmpl" ||
	     $type eq "category_tmpl" || $type eq "monthly_tmpl") {
	my $file = shift;
	open(OUT, ">$file") || die;
	my $url = "http://cms.blog.livedoor.com/cms/design/edit"
	    . "?tmpl=$type&blog_id=$BlogID&id=$ID";
	my $req = new HTTP::Request GET => $url;
	my $res = $ua->request($req);
	if ($res->content =~
	    /\<textarea .*name=\"content\" [^\>]*\>([^\<]+)\<\/textarea\>/) {
	    my $content = unescapeHTML($1);
	    $content =~ s/\r\n/\n/g;
	    print OUT $content, "\n";
	}
	close(OUT);
    } elsif ($type eq "raw_log") {
	my $npage = shift;
	($npage =~ m/^\d+$/ && $npage >= 1) || &help;
	my $file = shift;
	&help unless $file;
	open(OUT, ">$file") || die;
	my $url = "http://analyzer.livedoor.com/log/raw?page_id=$PageID";
	if ($Date) {
	    $url .= "&y=$Year&m=$Month";
	}
	my $prepat = '\<td\b[^\>]*\>\<strong\>\<small\>';
	my $postpat = '\<\/small\>\<\/strong\>\<\/td\b[^\>]*\>';
	my $datematch = 0;
	pages: for (my $i=1; $i <= $npage; $i++) {
	    my $req = new HTTP::Request GET => "$url&p=$i";
	    my $res = $ua->request($req);
	    my $datepat = '\d\d\d\d\-\d\d\-\d\d \d\d\:\d\d\:\d\d';
	    my $date;
	    for (split(/(\<small\>$datepat\<\/small\>)/o, $res->content)) {
		if (/^\<small\>($datepat)\<\/small\>$/o) {
		    $date = $1;
		} elsif (/^\<\/th\>\s*\<\/tr\>\s*/) {
		    my @record;
		    for (split(/\<\/tr\>\s*/, $')) {
			my $column;
			if (/$prepat(.*)$postpat/o) {
			    if ($1 eq 'URL') {
				$column = 0;
			    } elsif ($1 eq 'リファラ') {
				$column = 1;
			    } elsif ($1 eq 'ブラウザ') {
				$column = 2;
			    } elsif ($1 eq 'リモートホスト') {
				$column = 3;
			    } else {
				die "Unknown column: $_\n";
			    }
			}
			if (/\<td\b[^\>]*\>\<small\>(.*)\<\/small\>\<\/td\b[^\>]*\>/){
			    $_ = $1;
			    s/\<\/?a\b[^\>]*\>//g;
			    if (/,/) {
				s/\"/\"\"/g;
				$_ = "\"$_\"";
			    }
			    $record[$column] = $_;
			} elsif (/^\<\/table\>/) {
			    last;
			} elsif (! /^\<tr\>\s*\<th\b[^\>]*\>/) {
			    die "Unknown format: $_\n";
			}
		    }
		    if (! defined($Date) || $date =~ /^$Date/) {
			$datematch = 1;
			print OUT $date, ",", join(',', @record), "\r\n";
		    } elsif ($datematch) {
			last pages;
		    }
		}
	    }
	}
	close(OUT);
    } elsif ($type eq "export_reserve") {
	my $url = "http://cms.blog.livedoor.com/cms/import/mt/export_reserve";
	my $req = new HTTP::Request GET => $url;
	my $res = $ua->request($req);
	if (! $res->is_success) {
	    print STDERR "fail to reserve export";
	    exit 1;
	}
    } elsif ($type eq "export") {
	my $file = shift;
	open(OUT, ">$file") || die;
	my $url = "http://cms.blog.livedoor.com/cms/import/mt/export";
	my $req = new HTTP::Request GET => $url;
	my $res = $ua->request($req);
	print OUT $res->content;
	close(OUT);
    } else {
	&help;
    }
}
exit 0;

sub help {
    print STDERR "Usage livedoor <blog> <opt>...\nblog: ",
    join("\n      ", keys %blogs), "\n",
    'opt:  date YYYY-MM
      date YYYY-MM-DD
      css <file>
      index_tmpl <file>
      article_tmpl <file>
      category_tmpl <file>
      monthly_tmpl <file>
      raw_log <n> <file>
      export_reserve
      export <file>
';
    exit 1;
}

hiroaki_sengoku at 08:45｜この記事のURL │Comments(0) │TrackBack(0)

2006年04月30日

livedoor blog 生ログ取得スクリプト (1)

すでに誰かが絶対に書いているはずとは思ったのですが、探すよりも書いた方が早そうだったので、 livedoor ブログの生ログを取得する perl スクリプトを書いてみました。ついでに、デザインをカスタマイズしたときの、スタイルシート（CSS）やHTMLのテンプレートも取得できます。例えば、

livedoor.pl gcd raw_log 10 log.csv

などと実行すれば、10 ページ分 (200行) の生ログを、 CSV 形式でファイル「log.csv」に保存できます。また、

livedoor.pl gcd index_tmpl index.html

などと実行すれば、インデックスページのHTMLテンプレートを、ファイル「index.html」に保存できます。第一引数「gcd」の部分には、ブログのアカウント名 (スクリプトの先頭部分で定義しています) を指定してください。私の場合、「GCD 日記」と「仙石浩明CTO の日記」の二つのブログアカウントがあるので、それぞれ「gcd」と「klab」という名前で定義しています。

余談ですが、二つのブログを書いているのは、個人用と会社用とを区別しようというわけではありません。もともと私のなかでは趣味と仕事の境界線が曖昧なので、個人と会社でブログを区別しようとしても混ざってしまうでしょうから、区別することに意味があるとは思えません。じゃ、なぜ二つのブログなのかと言えば、「GCD 日記」のほうがよりメモ的でネタを蓄えておき、ある程度考えがまとまったものを「仙石浩明CTO の日記」へ書こう、というのがそもそもの意図でした。

やっつけ仕事なので、突っ込みどころ満載(^^;) のスクリプトだとは思いますが、 livedoorブログをお使いの方はご利用頂ければ幸いです。もちろん、ご利用の際は先頭部分のユーザID & パスワード等を適宜修正してください。また、スクリプト中で日本語を使っているので、このスクリプトは EUC-JP で保存する必要があります。

livedoor.pl (livedoor blog 生ログ & CSS/テンプレート取得スクリプト)

#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Request::Common;
use CGI qw/unescapeHTML/;

%blogs = (
    "gcd" => { 
	"User"   => "hiroaki_sengoku",
	"Pass"   => "xxxxxxxx",
	"BlogID" => 1600549,
	"ID"     => 11111,
	"PageID" => 22222,
    },
    "klab" => {
	"User"   => "klab_sengoku",
	"Pass"   => "yyyyyyyy",
	"BlogID" => 1631449,
	"ID"     => 33333,
	"PageID" => 44444,
    },
);

&help unless $_ = shift;
if (my $blog = $blogs{$_}) {
    $User =   $$blog{"User"};
    $Pass =   $$blog{"Pass"};
    $BlogID = $$blog{"BlogID"};
    $ID =     $$blog{"ID"};
    $PageID = $$blog{"PageID"};
} else {
    &help;
}

$ua = new LWP::UserAgent;
$ua->agent("Mozilla/5.0 (Windows; U; Windows NT 5.1; ja)");
$ua->env_proxy();
$ua->cookie_jar( {} );
my $res = $ua->request(POST "http://member.livedoor.com/login/index",
		       [ "livedoor_id" => $User, "PASSWORD" => $Pass,
			 ".next" => "", ".sv" => "" ]);
while (my $type = shift) {
    if ($type eq "css" || $type eq "index_tmpl" || $type eq "article_tmpl" ||
	$type eq "category_tmpl" || $type eq "monthly_tmpl") {
	my $file = shift;
	open(OUT, ">$file") || die;
	my $url = "http://cms.blog.livedoor.com/cms/design/edit"
	    . "?tmpl=$type&blog_id=$BlogID&id=$ID";
	my $req = new HTTP::Request GET => $url;
	my $res = $ua->request($req);
	if ($res->content =~
	    /\<textarea .*name=\"content\" [^\>]*\>([^\<]+)\<\/textarea\>/) {
	    my $content = unescapeHTML($1);
	    $content =~ s/\r\n/\n/g;
	    print OUT $content, "\n";
	}
	close(OUT);
    } elsif ($type eq "raw_log") {
	my $npage = shift;
	($npage =~ m/^\d+$/ && $npage >= 1) || &help;
	my $file = shift;
	open(OUT, ">$file") || die;
	my $url = "http://analyzer.livedoor.com/log/raw?page_id=$PageID";
	my $prepat = '\<td\b[^\>]*\>\<strong\>\<small\>';
	my $postpat = '\<\/small\>\<\/strong\>\<\/td\b[^\>]*\>';
	for (my $i=1; $i <= $npage; $i++) {
	    my $req = new HTTP::Request GET => "$url&p=$i";
	    my $res = $ua->request($req);
	    my $datepat = '\d\d\d\d\-\d\d\-\d\d \d\d\:\d\d\:\d\d';
	    my $date;
	    for (split(/(\<small\>$datepat\<\/small\>)/, $res->content)) {
		if (/^\<small\>($datepat)\<\/small\>$/) {
		    $date = $1;
		} elsif (/^\<\/th\>\s*\<\/tr\>\s*/) {
		    my @record;
		    for (split(/\<\/tr\>\s*/, $')) {
			my $column;
			if (/$prepat(.*)$postpat/o) {
			    if ($1 eq 'URL') {
				$column = 0;
			    } elsif ($1 eq 'リファラ') {
				$column = 1;
			    } elsif ($1 eq 'ブラウザ') {
				$column = 2;
			    } elsif ($1 eq 'リモートホスト') {
				$column = 3;
			    } else {
				die "Unknown column: $_\n";
			    }
			}
			if (/\<td\b[^\>]*\>\<small\>(.*)\<\/small\>\<\/td\b[^\>]*\>/){
			    $_ = $1;
			    s/\<\/?a\b[^\>]*\>//g;
			    if (/,/) {
				s/\"/\"\"/g;
				$_ = "\"$_\"";
			    }
			    $record[$column] = $_;
			} elsif (/^\<\/table\>/) {
			    last;
			} elsif (! /^\<tr\>\s*\<th\b[^\>]*\>/) {
			    die "Unknown format: $_\n";
			}
		    }
		    print OUT $date, ",", join(',', @record), "\r\n";
		}
	    }
	}
	close(OUT);
    } else {
	&help;
    }
}
exit 0;

sub help {
    print "Usage livedoor <blog> <opt>...\nblog: ",
    join("\n      ", keys %blogs), "\n",
    'opt:  css <file>
      index_tmpl <file>
      article_tmpl <file>
      category_tmpl <file>
      monthly_tmpl <file>
      raw_log <n> <file>
';
    exit 1;
}

hiroaki_sengoku at 09:07｜この記事のURL │Comments(0) │TrackBack(0)

2006年04月28日

Haskell

遅ればせながら Haskell で遊んでいます。 KLab の技術者の中にも、手続き型言語の世界にどっぷりつかっていて他の世界を知らない人はいるので、 tech ML (技術者向の KLab 社内メーリングリスト) で Haskell の紹介をしてみました。

～～ tech ML に投げたメールここから～～

Subject: [tech:8480] Haskell

仙石です。

唐突ですが、Haskell って知ってますか？

私は面接した人に教えてもらった ;) のですが、最近流行りの関数型言語です。
ブログを見てると、あちこちで話題になっていますね。
入門用のページ:

  やさしい Haskell 入門 (バージョン98)
  http://www.sampou.org/haskell/tutorial-j/index.html

「やさしい」と書いてますが、関数型言語を初めて学ぼうとする人には敷居が 
高いかも知れません。まずは簡単な Haskell プログラムを見てみましょう。

------------------------------------------------------------------------
guusuu x
  | x `mod` 2 == 0  =  True
  | otherwise       =  False
------------------------------------------------------------------------

これは guusuu(x) という関数の定義です。

  x を 2 で割った余りが 0 ならば、guusuu(x) = True
  それ以外ならば、                guusuu(x) = False

と読みます。簡単ですね？ ;)
早速実行してみましょう。
上記プログラムを test.hs というファイル名で保存しておいて、
Haskell 処理系である ghci コマンドを実行します。

------------------------------------------------------------------------
senri:/home/sengoku/tmp % ghci
   ___         ___ _
  / _ \ /\  /\/ __(_)
 / /_\// /_/ / /  | |      GHC Interactive, version 6.4.2, for Haskell 98.
/ /_\\/ __  / /___| |      http://www.haskell.org/ghc/
\____/\/ /_/\____/|_|      Type :? for help.

Loading package base-1.0 ... linking ... done.
Prelude> :load test.hs
Compiling Main             ( test.hs, interpreted )
Ok, modules loaded: Main.
*Main> guusuu 2
True
*Main> guusuu 7
False
*Main> 
------------------------------------------------------------------------

「:load test.hs」というのが「test.hs」を読み込むためのコマンドです。
「guusuu 2」を実行すると、guusuu(2) の値である True が出力されていますね。
これだけだと、あまり能がないので、偶数列を表示させてみましょうか。

------------------------------------------------------------------------
*Main> take 10 [1,2..]
[1,2,3,4,5,6,7,8,9,10]
*Main> take 10 [x|x <- [1,2..], guusuu x]
[2,4,6,8,10,12,14,16,18,20]
------------------------------------------------------------------------

「take 10」というのはその後ろのリストの先頭 10 個の要素を取り出す関数で
す。「[1,2..]」というのは自然数列のリストですね。take を使わずに [1,2..] 
を表示させようとすると、無限に自然数列を表示します。

------------------------------------------------------------------------
*Main> [1,2..]
[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22, ...無限に続く...
------------------------------------------------------------------------

途中で止めるには control-C を押します。
さて、

  [x|x <- [1,2..], guusuu x]

という書き方は、グラフ理論の輪講に参加している人や、述語論理を学んだこと
のある人にはおなじみの書き方じゃないでしょうか。自然数列の中で、
述語 guusuu(x) が True であるような x のみ取り出したリスト、という意味です。

じゃ、このプログラムはどうでしょう？

------------------------------------------------------------------------
hurui [] = []
hurui (top:rest) = top:(hurui [x|x <- rest, x `mod` top /= 0])
------------------------------------------------------------------------

関数 hurui は引数としてリストをとります。「[]」は空リストです。つまり要
素が何もないリストですね。引数が空リストならば hurui [] の値も [] です。

引数が [] でない場合は、引数のリストを、先頭 top と残り rest に分解します。
例えば hurui [3,5,9,11,13] の場合、top が 3 で rest が [5,9,11,13] です。

# このあたり、lisp を知っている人にはおなじみの概念ですね

次に top と (hurui [x|x <- rest, x `mod` top /= 0]) をつなげたリストを、 
hurui の値として返します。「:」がリストを作るための演算子です。

# lisp で言うところの cons と言えば lisp を知っている人には簡単ですね

では (hurui [x|x <- rest, x `mod` top /= 0]) とは何でしょう？

「/=」というのは等しくない、という演算子です。C で言うところの「!=」です
ね。つまり、rest の中で「x `mod` top /= 0」が True になるものを取り出し
たリストを求め、これを引数として hurui を再帰呼出しして求めたリスト、と
いうことになります。

top が 3 で rest が [5,9,11,13] でしたから、3 で割って余りが 0 でない 
(つまり 3 で割り切れない) もののリスト、ということになります。9 以外は 3 
で割り切れないので [5,11,13] ですね。これを引数として hurui に与えます。
つまり、3 (top の値) と hurui [5,11,13] の値をつなげたリストが答になりま
す。

同様に hurui [5,11,13] の値は、5 と hurui [11,13] (11 も 13 も 5 では割
り切れないから) の値をつなげたリストですね。というのをどんどん再帰的に繰
り返すと、hurui [3,5,9,11,13] の値は [3,5,11,13] になります。実際に試し
てみましょう:

------------------------------------------------------------------------
*Main> hurui [3,5,9,11,13]
[3,5,11,13]
------------------------------------------------------------------------

スルドイ人はすでに分かっていると思いますが、
この関数は「エラトステネスの篩」です。したがって、

------------------------------------------------------------------------
*Main> take 20 (2:hurui [3,5..])
[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71]
------------------------------------------------------------------------

などと実行することにより、20個の素数を列挙することができました。

どうです？ 面白いでしょう？

関数型言語を知っている人は、たぶん Haskell もすぐ使いこなすことができる
と思いますし、関数型言語を知らない人は、ぜひこの機会に知ることをオススメ
します。なぜなら関数型言語を知らないプログラマってプログラミング言語の世
界の半分しか知らないわけで、Haskell を学ぶことにより世界が大きく広がると
思うからです。

関数型言語を初めて学ぶ人は、まずは

  入門Haskell―はじめて学ぶ関数型言語
  向井 淳 (著) 

あたりを読むのがいいかも知れません。私の机の上に置いておくので、興味ある
かたはどーぞ (先着一名様限定)。

この本は、副題にもあるように関数型言語を初めて学ぶ人向けに書かれているの
で、イマイチ本質を外しているんですよねぇ... だから本音ではオススメな本で
はない ;-) のですが、関数型言語へのとっかかりとしてはよいのかも知れません。

#13425                                                          仙石 浩明
http://www.gcd.org/sengoku/             Hiroaki Sengoku <sengoku@gcd.org>

～～ tech ML に投げたメールここまで～～

このメールに一番早く反応したのは、KLab の開発に参加いただいている協力会社 H 社の CTO の T さんでした。 T さんとはご無沙汰していたのですが、彼も私と同様に Haskell で遊んでいたことが分かって、さすがと思った次第。

# 協力会社さんに負けずに頑張ってね＞ KLab 社員

～～ T さんのメール(一部抜粋)ここから～～

ご無沙汰しております。
H 社の T です。

Hiroaki Sengoku wrote:
> 唐突ですが、Haskell って知ってますか？

なぜか私も、今月の頭ぐらいにとあるブログで知って（YAPC::Asia 2006のPugs関連
のエントリだったような…）

>   入門Haskell―はじめて学ぶ関数型言語
>   向井 淳 (著)

を購入して、ひそやかに楽しんでおりました。
そして、いやあ、これは、自分だけ楽しんでいるには余りにももったいないので、
（H社内の）勉強会のネタにしようと宣言していた矢先に、投稿を拝見しまして、
つい反応してしまいました。

～～ T さんのメール(一部抜粋)ここまで～～

KLab でも Haskell 勉強会やりましょう!

hiroaki_sengoku at 06:32｜この記事のURL │Comments(0) │TrackBack(0)