Weblogs.Com changes.xml を吐いたりする Ping サーバの Perl 実装

昨日は changes.xml を入力として使う方法について記述しました。('Weblogs.Com changes.xml を Perl で料理する一例') 今度は出力ですが、これも XML::Simple を使うことで簡単にできます。

ただ出力させるだけじゃ面白くないので、先日解説した Ping サーバに changes.xml を出力すると共に幾つかの処理を考えて、以下のようなものを作ってみました。

1. Ping を受信すると、その情報を DB に格納する
2. 受け取った Ping の URL の先の HTML から RSS の URL を探し出し、RSS から最新記事のタイトルとURLを取得、DB に格納する。
3. DB から 1. の情報を読み出して changes.xml を出力する

DB には MySQL を使い、Class::DBI を使ってデータの出し入れを行います。Class::DBI はデータベースを使って永続オブジェクトを実現するための CPAN モジュールで、SQL をほとんど書かずに DB を操作できるというかなり便利なクラスです。EJB の Entity Bean のようなことを Perl で手軽に実現できるクラスと言えば分かりやすいかもしれません。

Ping の受信時、ウェブログの名前とその URL が XML-RPC リクエストの引数として渡ってきます。この情報を Class::DBI で保存しておき、3. 3. の changes.xml の作成その他で利用します。

changes.xml を作るだけでは面白くないので、Ping を受け取ったら、逆に今度は送信元のコンテンツから記事のタイトルを取ってくるような処理をさせてみました。それが 2. にあたります。Ping のパラメータにはウェブログの URL しか載っておらず、どうやってタイトルを取得するかが課題になりますが、ここでは RSS::Autodiscovery という CPAN モジュールを使って HTML から RSS の URL を探し出し、RSS を LWP::Simple で取得、XML::RSS でパースして最新記事のタイトルを得る、という流れで処理しました。

changes.xml の出力には XML::Simple を使いました。XMLout というメソッドがあるのですが、ハッシュやリストを使って作ったデータ構造を渡してやれば XML エンコードなどの処理も行った上で XML 文書を出力してくれます。

MySQL 上に作ったテーブルのスキーマは以下のようになっています。データベース名は ping 。weblog 表、weblogUpdates 表は changes.xml の weblog 要素、weblogUpdates 要素にそれぞれ対応します。Ping を受け取った際に、weblog 表に名前(name)、URL(url)、受信時刻(datetime) を挿入します。一方、weblogUpdates 表には changes.xml を更新する際、累計更新回数(count)、更新日時(updated)を挿入します。(なお、データベースに日本語を挿入する場合は EUC-JP で、changes.xml は UTF-8 で出力する方針でいきます。)

mysql> desc weblog;
+----------+------------------+------+-----+---------------------+----------------+
| Field    | Type             | Null | Key | Default             | Extra          |
+----------+------------------+------+-----+---------------------+----------------+
| id       | int(10) unsigned |      | PRI | NULL                | auto_increment |
| name     | varchar(255)     |      |     |                     |                |
| url      | varchar(255)     |      |     |                     |                |
| datetime | datetime         |      |     | 0000-00-00 00:00:00 |                |
+----------+------------------+------+-----+---------------------+----------------+
4 rows in set (0.00 sec)
 
mysql> desc weblogUpdates;
+---------+------------------+------+-----+---------------------+----------------+
| Field   | Type             | Null | Key | Default             | Extra          |
+---------+------------------+------+-----+---------------------+----------------+
| count   | int(10) unsigned |      | PRI | NULL                | auto_increment |
| updated | datetime         |      |     | 0000-00-00 00:00:00 |                |
+---------+------------------+------+-----+---------------------+----------------+
2 rows in set (0.00 sec)

また、RSS から取った最新記事の名前(title)、URL(permalink) を保持する entry 表のスキーマは以下です。id は weblog 表の id と対応します。

mysql> desc entry;
+-----------+------------------+------+-----+---------+-------+
| Field     | Type             | Null | Key | Default | Extra |
+-----------+------------------+------+-----+---------+-------+
| id        | int(10) unsigned |      | PRI | 0       |       |
| title     | varchar(255)     | YES  |     | NULL    |       |
| permalink | varchar(255)     | YES  |     | NULL    |       |
+-----------+------------------+------+-----+---------+-------+
3 rows in set (0.00 sec)

次に、それぞれのテーブルに対応するクラスです。weblog 表に対応するのは Ping::Weblog というクラス。

package Ping::Weblog;
 
use strict;
use base qw (Class::DBI);
 
__PACKAGE__->set_db('Main', 'dbi:mysql:ping', 'dbuser', 'dbpass', { RaiseError => 1 } );
__PACKAGE__->table('weblog');
__PACKAGE__->columns( Primary => qw (id) );
__PACKAGE__->columns( All => qw (name url datetime) );
__PACKAGE__->add_constructor( recent => 'UNIX_TIMESTAMP(NOW()) - UNIX_TIMESTAMP(datetime) < ? ORDER BY datetime DESC' );
 
1;

Class::DBI を継承して、set_db や table、columns メソッドで対応する DB やテーブルを設定しています。たったのこれだけで、例えば

use Ping::Weblog;
 
my $weblog = Ping::Weblog->retrieve(1);
print $weblog->name;

とすれば id = 1 のウェブログの名前が出力できます。retrieve や search といったメソッドの発行時に Class::DBI が SQL を発行してレコードを Ping::Weblog インスタンスとして返してくれるので、そのインスタンスのアクセサで各カラムの値を得る事ができるという仕組み。

add_constructor メソッドは、Class::DBI がデフォルトで提供する retrieve、search、create といったメソッドが内部で発行する SQL では対応できない SQL 文を定義するためのもの。ここでは、Ping::Weblog->recent(10800) とかして datetime が直近三時間以内であるレコードを取り出せるように定義しています。

同様にして、weblogUpdates 表、entry 表に対応するクラスは以下の通りになります。

package Ping::WeblogUpdates;
 
use strict;
use base qw (Class::DBI);
 
__PACKAGE__->set_db('Main', 'dbi:mysql:ping', 'dbuser', 'dbpass', { RaiseError => 1} );
__PACKAGE__->table('weblogUpdates');
__PACKAGE__->columns( Primary => qw (count) );
__PACKAGE__->columns( ALL => qw (updated) );
 
1;

package Ping::Entry;
 
use strict;
use base qw (Class::DBI);
 
__PACKAGE__->set_db('Main', 'dbi:mysql:ping', 'dbuser', 'dbpass', { RaiseError => 1 } );
__PACKAGE__->table('entry');
__PACKAGE__->columns( Primary => qw (id) );
__PACKAGE__->columns( All => qw (title permalink) );
 
1;

Class::DBI はほんと便利です。:)

さて、メインの Ping サーバスクリプト、ping.cgi のソースコードは以下です。XML-RPC サーバとして動作します。(先日のエントリ 'Weblogs.Com Ping の Perl による実装' に XML-RPC サーバの実装方法を記述しています。) クライアントから weblogUpdates.ping が呼ばれる、すなわち Ping が投げられると、_doTask() が呼び出されて中でごにょごにょするという内容です。

#!/usr/local/bin/perl
use strict;
use warnings;
use Lingua::JA::Regular;
use XMLRPC::Transport::HTTP;
use HTML::RSSAutodiscovery;
use XML::RSS;
use XML::Simple;
use Jcode;
use LWP::Simple;
use Date::Format;
use Date::Parse;
use Ping::Weblog;
use Ping::WeblogUpdates;
use Ping::Entry;
 
XMLRPC::Transport::HTTP::CGI->dispatch_to('weblogUpdates::ping')->handle;
 
package weblogUpdates;
 
sub ping {
     my $self = shift;
     my ($name, $url) = @_;
 
     eval {
 	_doTask( name => $name, url =>  $url );
    }; if ($@) {
	_errorReport( "error", $@ );
	return { flerror => XMLRPC::Data->type('boolean', 1), message => $@ };
    }
 
    return { flerror => XMLRPC::Data->type('boolean', 0), message => "Thanks for the ping" };
}
 
sub _doTask {
    my %args = @_;
 
    # DB に Ping 情報挿入
    my $new_blog = Ping::Weblog->create( { name     => Jcode->new( $args{name} )->euc,
					   url      => $args{url},
					   datetime => _mysqldatetime(time) });
     
    my $prop = {};
    eval {
	$prop = _getNewEntryProperty ( $args{url} );
    }; if ($@) {
	_errorReport( "info", $@ );
    }
     
    # DB に最新記事情報挿入
    my $entry = Ping::Entry->create( { id        => $new_blog->id,
				       title     => $prop->{title},
				       permalink => $prop->{permalink} });
 
    # changes.xml の更新. (何もこのスクリプトでやらなくてもいい.)
    my @weblogs;
    my $now = time;
     
    for my $weblog (Ping::Weblog->recent(10800) ) {
	push @weblogs, { name => Jcode->new( $weblog->name, 'euc' )->utf8,
			 url => $weblog->url,
			 when => $now - Date::Parse::str2time( $weblog->datetime ) };
    }
     
    my $weblogUpdates = Ping::WeblogUpdates->create( { updated => _mysqldatetime($now) });
     
    my $root = {
	version => 1,
	updated => _rfc822date($now),
	count   => $weblogUpdates->count,
	weblog  => \@weblogs
	};
     
    my $parser = XML::Simple->new;
    $parser->XMLout( $root,
		     OutputFile => './changes.xml',
		     RootName => 'weblogUpdates',
		     XMLDecl => '<?xml version="1.0" encoding="UTF-8"?>' );
}
 
sub _getNewEntryProperty {
    my $url = shift;
    my $rss_url;
     
    if ( $url =~ /(rdf|rss|xml)$/) {
	$rss_url = $url;
    } else {
	my $html = HTML::RSSAutodiscovery->new;
 	
	if ( my $result = $html->parse ( $url ) ) {
	    $rss_url = $result->[0]->{href};
	}
    }
 
    die "could not determine RSS url. (source: $url)" if (not defined $rss_url);
 
    my $parser = new XML::RSS;
    my $rss = Lingua::JA::Regular->new( LWP::Simple::get( $rss_url ) )->regular;
    $parser->parse($rss);
    my $title = Jcode->new($parser->{items}->[0]->{title})->euc || ""; 
    my $permalink = $parser->{items}->[0]->{link} || "";
     
    return { title => $title, permalink => $permalink };
}
 
sub _mysqldatetime {
    my $time = shift;
 
    Date::Format::time2str("%Y-%m-%d %T", time);
}
 
sub _rfc822date {
    my $time = shift;
 
    Date::Format::time2str("%a, %d %h %Y %T %Z", $time, 'GMT');
}
 
sub _errorReport {
    my ($level, $errstr) = @_;
 
    local *LOG;
    open LOG, ">> ./error.log" or exit(1);
 
    $errstr .= "\n" unless ($errstr =~ /\n$/);
    print LOG _mysqldatetime(time), " [$level] ",  $errstr;
     
    close LOG;
}

_doTask() では Ping::Weblog->create なんてことをしていますが、これは RDMBS への INSERT に等しい処理となります。create メソッドを呼び出すだけで、RDBMS への保存が完了するというわけです。

_getNewEntryProperty() はウェブログの最新記事のタイトルとURLを取得するサブルーチン。HTML::RSSAutodiscovery->parse で RSS の URL を取得して、LWP::Simple::get で文書を GET してます。XML::RSS でパースする前に Lingua::JA::Regular を使って機種依存文字の排除といった日本語の正規化を行ってます。(機種依存文字を含めたまま XML::RSS にパースさせるとエラーとなるため。) XML::RSS のパース結果から一番上のエントリの title 要素と link 要素を抜き出して、サブルーチン呼び出し下に返却します。(Perl 5.8.0 を使っていると XML::RSS がパースした結果が文字化けしてしまい復元不可能となってしまいはまりました。原因不明。しょうがないので 5.6.0 を使ってます)。

_getNewEntryProperty() で取得した情報を entry 表に保存するのは、先ほどの Ping::Weblog->create に同じく、Ping::Entry->create で完了です。

changes.xml の出力は、DB から直近三時間の Ping 情報を復元、changes.xml にあわせたデータ構造を構築して XMLout に渡し出力するという流れになってます。かなりあっさりです。ここでは敢えて Ping 受信の毎に changes.xml を更新するような処理を記述していますが、あまりいろいろやると負荷も高くなるし、クライアント側も Ping 送信終了までに時間がかかるので、Ping を DB に保存するところまでやって changes.xml は DB 読み出し→出力する部分だけ別途 cron で実行するなどして生成するのが吉かも。

なお、Weblogs.Com を始めとする大概の Ping サーバは、受け取った Ping の情報を changes.xml などで公開しているので、それを利用すればわざわざ自分で Ping サーバを立てて、Ping を打ってもらう必要はないでしょう。しかしながら Ping の受信元となっていると、このスクリプトがそうであるように、Ping の受信と同時に何かしらのアクションを起こす処理が行えるという魅力があります。(ここでは、送信元の RSS から最新記事のタイトルを引っ張っています。) Ping ドリブン処理とでもいいましょうか。そのとき更新されたウェブログがほぼリアルタイムにピンポイントで分かるので、ロボットなどを作ったとしても巡回にかかるコストがかなり下がります。

例えば更新した直後からもう検索にヒットする検索エンジンを構築したければ、Ping 受信と同時に検索データベースにレコードを挿入するような処理を記述すれば可能ですし、Ping 受信と同時に IRC の bot などでチャンネルに新着記事の内容を配信するとか、応用事例は色々考えられます。ただ、あちこちに Ping サーバが立って分散するのはあまり好ましくないので、できれば changes.xml などを利用する方向で色々やったほうがいいのかなと思います。

眠くなってきたので残りの解説はまた今度. 一応、http://naoya.dyndns.org/~naoya/XMLRPC/ping.cgi で動いてます。ping を打つ URL にこの URL を指定して使います。changes.xml は http://naoya.dyndns.org/~naoya/XMLRPC/changes.xml です。

Posted by naoya at August 30, 2003 03:07 AM | トラックバック (5)