Socket Cooking Book with perl5 volume2

このテキストは perl でソケットプログラミングをするためのクッキング・ブックです。私自身はあまりソケットを使ったプログラミングはしたことがありません。しかし、perl の perlipc マニュアルページを読んで色々やって見たら敷居の高そうなソケットプログラミングも簡単に出来ることがわかったので、初心者の方々(私もそうなんですが) にもわかるように書いて見たつもりです。まあ、自分の理解力を試すために書いたようなテキストです。

この巻は第一巻クライアント編の続編です。当初はそんなに大部になるとは思っていなかったのですが、色々な例をあげていくうちにファイルをいくつかに分けなければならなくなってしまいました。くどい程サンプルが出ているテキストと言うのもあまりないので、ディスクの肥しにどうぞ。内容的にはちょっと重いかもしれません。

なお、テキスト中のスクリプトはすべて UNIX (FreeBSD 3.2-RELEASE) で動作確認をしていますが、 Windows 95/98 では動作確認をしていません。

この巻からはサーバの書き方について考えて見ることにする。むろん、第一巻の内容は知っているものとして話を進めるが、クライアントを書く手前の『基礎知識』まで読んでもらえれば十分である。ただし、クライアント編は手元において必要なら参照できるようにした方がいいかも知れない。

サーバとクライアントでは書き方が全く違うということは既に指摘した。まずは、サーバのセットアップの仕方について具体的なコードを見ながら基本事項をまとめて見よう。次は実につまらないサーバの例である。クライアントが接続すると "Hello!! Are you fine?" などというメッセージをクライアントに返して終了する。

#!/usr/bin/perl -Tw
use strict;
use Socket;
use Carp;
my $EOL = "\015\012";

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

my $paddr = accept(Client,Server);

print Client "Hello!! Are you fine?$EOL";  

close(Client)                                       || die "close: $!";
exit;

このサーバをテストするには通常の telnet コマンドをつかう。

host% telnet localhost 2345
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
Hello!! Are you fine?
Connection closed by foreign host.
host%

ではコードを説明しよう。第一巻で説明したサーバの動作を思い出して欲しい。

まず、ソケットのセットアップをしなければならない。対応するのは次の部分である。

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";

今の場合プロトコルは tcp であるから、当然 SOCK_STREAM を選択する。またマシン間のインターネットドメインソケットを使うのでプロトコルファミリの指定も PF_INET である。ソケットハンドルのところは自分の好きな名前にしてよい。上の例では、 Server にしてある。次に、システムに対して上のように指定したポート 2345 でサービスを提供する旨通知する。それをしているのが、

bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";

である。なお、ポート番号については、1 から 1023 までは root 権限で起動したプロセスでなければ使用できない。従って、何も 2345 にする必要はないが、 1024 よりは大きな番号のポートにしなければならない。このような大きな番号のポートを短命ポート(エフェメラル・ポート)とよぶ。

また、上のように INADDR_ANY を指定する。そうすれば、マルチホーム (つまり、IP アドレスが複数割り当てられているマシン) の場合にもすべてのアドレスからアクセスできる。

listen(Server,SOMAXCONN)                            || die "listen: $!";

これはクライアントの待ち行列を決める。これを指定しておくと要求があった際にすぐに応答できない場合にはクライアントに待ってもらうことが出来る。ただし、待たせることの出来るクライアントの数はそんなに多くない。通常、最大値の SOMAXCONN を指定しておく。

my $paddr = accept(Client,Server);

ここで、クライアントの接続を待っている。上の場合だとクライアントに応答する場合には Client というソケットハンドルを使う。

print Client "Hello!! Are you fine?$EOL";  

close(Client)                                       || die "close: $!";

応答の仕方は今までと変わらない。応答したら、コネクションを切る。

以上がサーバのコードの流れである。しかし、一回接続したらサーバも終了してはほとんど使いものになるとも思われないので、ずっと動作していていつでもクライアントの要求に応対できる方が便利であるし、普通そうである。

#!/usr/bin/perl -Tw
use strict;
use Socket;
use Carp;
my $EOL = "\015\012";

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

while(1){
  my $paddr = accept(Client,Server);
  my ($port, $iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr, AF_INET);

  print "connect from $name at port $port\n";
  print Client "Hello, $name!! Nice to meet you!! Are you fine?$EOL";  

  close(Client)                                       || die "close: $!";
}

要するに、無限ループで回しているに過ぎない。あとは、相手のアドレスを取得したりしているぐらいである。

以前に約束した、ブラウザのリクエストヘッダを見るスクリプトを紹介しよう。これは要するに、ブラウザの吐く環境変数というものを表示してくれるものである。ただ、いわゆる ENV チェッカーの類とは異なるのは、生のリクエストヘッダを表示すると言う点である。これで、自分のブラウザの吐いているリクエストヘッダーをチェックすれば、ファイル取得スクリプトや掲示板書き込みエージェントを作る際にいちいち RFC を読まなくてもいいし、掲示板へ送らなければならないデータもあらかじめ把握できる。

このソフトは、サーバとして実装される。ここも ENV チェッカーとは違う。 ENV チェッカーはアクセスした先の httpd から実行される子プロセスであり、 httpd はブラウザが送ったリクエストヘッダーにある情報を putenv して子プロセスに渡す。だから、これらの情報は CGI プログラムとしては環境変数として見えるのだ。実際にはリクエストヘッダーの情報の他にパケットから読み出せるリモートホスト情報も環境変数として CGI プログラムに渡される。

だから、このサーバが示すのは ENV チェッカーが示す情報の一部なのだが、フォームデータがどのように送られるかも示してくれる。うまく使えば、ある種の掲示板が行っているような、投稿コードの取得を妨害するようなメカニズムを見破ることも可能である。

また、このスクリプトはセキュリティチェックの部分を外せば簡単な proxy チェッカーとしても使える。別のポートを使ってクライアントと連携して動作するようにすればセキュリティの問題も回避されるだろう。

#!/usr/bin/perl -Tw
use strict;
use Socket;
my $EOL = "\015\012";

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

while(1){
  my $paddr = accept(Client,Server);
  my ($port, $iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr, AF_INET);

  if( !($name =~ /^localhost$/) ) {
    print Client "I cannot talk with you. Sorry.$EOL";
  }else{
    my $clienttext;
    my $contentlength = 0;
    my $entitybody;

    while( <Client> ){
      s/\015\012/\012/g;
      if( /^$/ ){
        $clienttext .= "\n";
        last;
      }
      if( /^Content-length: (\d+)/ ){ $contentlength = $1 }
      $clienttext .= $_;
    }
    if( $contentlength ){
      read( Client, $entitybody, $contentlength );
      $clienttext .= $entitybody;
    }
    print Client make_response($clienttext);
  }
  close(Client)                                       || die "close: $!";
}

sub make_response {
  my ($senttext) = @_;
  my $tmptime = scalar localtime;
  my $html =<<"END_html";
HTTP/1.0 200 OK
Date: $tmptime
Server: showheader.pl Server/1.0
Xonnection: close
Content-Type: text/html

<html>
<head>
<title>Server Response</title>
</head>
<body bgcolor="#000000" text="#ffffff">
<h1>You Sent ...</h1>
<p>
<pre>
$senttext
</pre>
</body>
</html>
END_html

  $html =~ s/\n/\015\012/g;
  return $html;
}

このサーバを使うのにはまず、ブラウザの proxy の設定のところをホストは localhost ポートは 2345 に設定しておく。それで、ブックマークやお気に入りにあるような適当なところにアクセスして見よう。すると、サーバがあなたが送ったものを送り返してくるはずだ。もちろん、それだけで、実際のページにはアクセスできないがブラウザが送っているものをこれで確認できるはずだ。むろん、適当なフォームデータも送って見よう。どうなっているかをじかに確かめることが出来るはずだ。

クライアント編のスクリプトが書ければ特に問題はないはずだ。ただ、ここで注意しないといけないことがある。セキュリティの問題だ。

UNIX を使っていればたとえ自宅のパソコン程度のちいさなマシンであってもセキュリティについては考えるだろう。だからそういった人には多くを言う必要はないだろう。問題は Windows 機のユーザである。デーモンプロセスを動かすということの恐さが良く分かっていないからである。上のようなヘッダを表示して見せる程度のものであっても、サーバである。そのようなプロセスを動かすにあって、場合によってはシステムの防御に大穴をあける可能性がある。外部からもそのサーバを利用することは可能なのだ。したがって、用途によってはアクセス制限をした方が良い。とくに、指示にしたがってコマンドを実行するサーバやファイルを扱うサーバを起動する場合には必ずサーバの方でアクセス制限をすること。上の場合にはアクセスして来たクライアントのホスト名を調べて localhost でなければ接続を切っている。ルーターのレベルでそれが可能なら外部からのサーバアクセスはさせないようにした方が良い。もしも、コマンドを実行するサーバに外部からのアクセスを許したら、自分で自分のマシンにトロイの木馬を仕込んだのと同じ結果になる。ちいさなスクリプトだが侮ってはいけない。

またスクリプトを書く際には厳格な文法チェックをした方が良い。これは、スクリプトの最初に

とすればよい。ただ perl4 イズムに染まっている人がこれをやるとエラーとウォーニングの嵐に見舞われるだろう。さらに、データフロー解析を行い taint check を有効化するオプション -T をつけた方が安全性は増す。ことに CGI スクリプトや不特定多数のユーザにサービスを提供するサーバを書く場合にはこのオプションをつけておいて損はない。

Gabrienai というソフトをご存知だろうか？ブラウザの名前をごまかしてくるソフトだ。私が入手したのはJava のものだった。これをここでは作ってみる。特にソケット関係で、新しいことはないが、ブラウザのフィルターとして使うという面白い用途なので取り上げてみた。考えようによっては、 proxy サーバの利用のされ方もこれに近い場合がある。リモートホストアドレスのフィルターとして利用されているというわけだ。

ここで取り上げるのは、いくつかのユーザエージェントをランダムに選択し、また、いくつかの proxy サーバをランダムに変更しながら web にアクセスする機能をもったものである。これは、サーバである一方、ブラウザの代理になってproxy サーバにアクセスするというクライアントの機能も持っている。 proxy サーバが送って来たドキュメントは、そのままブラウザに送られる。画像データもちゃんと中継してブラウザに表示される。もしも、あなたが使っている OS がテキストファイルとバイナリファイルをやかましく区別するのなら、 binmode でバイナリ指定してから使わないとうまくいかないかも知れない。

#!/usr/bin/perl -Tw
use strict;
use Socket;

my @agentlist =
(
 'Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)',
 'Mozilla/3.01 [ja] (Macintosh; I; PPC)',
 'Mozilla/4.0 (compatible; MSIE 4.01; Mac_PowerPC)',
 'Mozilla/2.02 (X11; I; UNIX_SV 4.2MP R4000)',
 'Mozilla /2000 (compatible; MSIE 2000; Windows 2000)',
 'Mozilla/4.6 [ja] (WinNT; I)',
 'wisp-ext1.docomo.ne.jp-DoCoMo/1.0/P501i',
 'Mozilla/4.08 [ja_JP.EUC] (X11; I; FreeBSD 3.2-RELEASE i386; Nav)'
 );

my @proxylist =
(
 'kraken.telstra.net:3128',
 'yellow.javanet.com:80',
 'invis-ascella.free.anonymizer.com:80',
 );
                     
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

$| = 1;
srand;
my $EOL = "\015\012";

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "perlgab server started on port $port";

while(1){
  my $paddr = accept(Client,Server);
  my ($port, $iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr, AF_INET);

  logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";

  if( !($name =~ /^localhost$/) ) {
    print Client "I cannot talk with you. Sorry.$EOL";
    logmsg "connection refused from $name [", inet_ntoa($iaddr), "] at port $port";
  }else{
    my $clienttext;
    my $contentlength = 0;
    my $entitybody;
    my $retbuff;

    while( <Client> ){
      $clienttext .= $_;
      if( /^Content-length: (\d+)/ ){ $contentlength = $1 }
      last if( /^\015/ );
    }
    if( $contentlength ){
      read( Client, $entitybody, $contentlength );
      $clienttext .= $entitybody;
    }
    $clienttext = fake_user_agent($clienttext);
    $retbuff = send_request($clienttext);
    print Client $retbuff;
  }
  close(Client)                                       || die "close: $!";
}

sub fake_user_agent {
  my ($buff) = @_;
  my $agent = $agentlist[int(rand($#agentlist+1))];

  $buff =~ s/User-Agent: [^\012\015]+/User-Agent: $agent/;
  return $buff;
}

sub send_request {
  my ($buff) = @_;
  my ($proxy, $proxyport) = split(':', $proxylist[int(rand($#proxylist+1))]);
  my ($iaddr, $paddr, $proto, $line);
  my $tmp = '';

  $iaddr   = inet_aton($proxy)                || die "host not found: $proxy";
  $paddr   = sockaddr_in($proxyport, $iaddr);

  $proto   = getprotobyname('tcp');
  socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
  connect(SOCK, $paddr)                      || die "connect: $!";

  logmsg "connecting to $proxy at port $proxyport";
  
  select(SOCK); $| = 1 ; select(STDOUT);
  print SOCK $buff;

  print $buff;

  while (defined($line = <SOCK>)) {
     $tmp .= $line;
  }

  close (SOCK)                                || die "close: $!";
  return $tmp;
}

ここでは特に新しいことはない。ユーザエージェントをごまかしているのは

sub fake_user_agent {
  my ($buff) = @_;
  my $agent = $agentlist[int(rand($#agentlist+1))];

  $buff =~ s/User-Agent: [^\012\015]+/User-Agent: $agent/;
  return $buff;
}

というサブルーチンで行っている。良くみれば単純な文字列置換をしているだけだ。このサーバの応用として、クッキーカッターが考えられる。これは後で考えて見ることにする。他にも、フィルターをかけるのはブラウザにデータを返す直前にして、うっとうしい広告類を除去するという応用もある。フィルター機能を最小限の手間で実現するのにはまさに perl はうってつけだ。広告類の除去の場合には Content-length の再計算が必要になるかも知れない。それだけに注意すればあとは同じ要領で出来る。逆に、あなたが広告屋を目指しているのなら、広告をつけてしまうという方法もある。上のスクリプト中にある。

invis-ascella.free.anonymizer.com:80

このサーバはまあまあうまく動く。しかし、完璧ではない。ブラウザの転送中止のボタンを押した時にうまく対応できていない。また、proxy サーバが反応しなかった時にも延々と待ち続ける。以下ではそれを修正することを考えてみよう。

おそらくこのセクションが一番難しいものになるはずだ。 UNIX ライクなオペレーティングシステムでは子プロセスを実行するのが一番難しい。中には、『何を？』という人もいるだろう。もしも、親プロセスが子プロセスの終了を停止して待つのであれば何も難しいことはいらない。実際かっての MS-DOS にはこの機能が実装されていた。これからするのは、正確に言えば、非同期に子プロセスを実行すると言うことだ。これはプリエンプティブなマルチタスクオペレーティングシステムというのを本質的に理解することと等価である。

難しさは他にもある。むろんこのテキストでは perl でのプログラミングを解説するのだが非同期に子プロセスを実行するのには、 C 言語で同種の機能をもったプログラムを書いた経験がないと理解しづらいと言うところにある。もう一つ、シグナルの扱いを知っておかなければならないと言うところにもある。

なぜここで子プロセスの実行について知らなければならないか説明しよう。設定にもよるが、ブラウザが html を読み込んだときに img タグを発見すればそれをとりにいく。ブラウザの動作を見ていればその場合に、矢継ぎ早にリクエストを発生しているのがわかるだろう。もしも、実際に画像データなどをとりにいくのを子プロセスに任せれば、同時にかなり動作は早くなることが期待できる。いままでのサーバは一つのデータをとって来てブラウザに返してから、またつぎのデータをとりに行った。これではパフォーマンスがあまりにも悪すぎる。割り当てられた帯域を十分に使えないからだ。

前の章までのタイプのサーバはリクエストを受けてからそれを処理して、再びリクエストを受ける状態に戻ることを繰り返す。このタイプのサーバは反復型サーバと呼ばれる。一方これから説明するのはリクエストの受け付けは一つのプロセスが行うもののリクエストの処理そのものは子プロセスに行わせる。複数の処理はいくつかの子プロセスが同時に処理する。このタイプのサーバを並行型サーバと呼ぶ。現実には反復型サーバよりも圧倒的に並行型サーバの方が多く存在している。

それでは UNIX オペレーティングシステムでの子プロセスの実行の手順を見てみよう。実際にはソケットプログラミングとは関係ないがファイルハンドルの二重化やパイプの実装の方法もみてみることにする。

まず次は色々と問題も多いが、子プロセスの実行の仕方を簡単に示した例である。

#!/usr/bin/perl

if( $pid = fork ) {
  print "I am the parent process. $$\n";
  print "pid is $pid.\n";
  exit(0);
}else{
  print "I am a child process. $$\n";
  print "pid is $pid.\n";
  exit(0);
}

exit;

host% perl fork.pl
I am a child process. 643
pid is 0.
I am the parent process. 642
pid is 643.
host%

最初に注意しなければならないのは、非同期に子プロセスを実行するのにいきなり exec を使ってはいけないということである。まず、新しいプロセスを生成しなければならない。それを行うのが fork(2) システムコールである。では生成された『新しいプロセス』とは何か？それは、 fork システムコールを呼び出した自分自身のコピーにほかならない。ただ割り当てられたプロセス ID は親のものとは違う。 fork(2) システムコールは呼び出した側(親プロセス)には複製されたプロセス (子プロセス)のプロセス ID を返す。一方、呼び出された側には 0 を返すようになっている。そうすると、 fork が何を返したかで条件分岐すれば一つのプログラムファイルの中に親プロセスのコードと子プロセスのコードを書くことが出来る。つまり、一般には次のようになっている。

if( $pid = fork ) {

  # $pid が 0 でない場合。すなわち、ここには親プロセスの
  # コードが来る。

}else{

  # $pid が 0 になる場合。すなわち、ここには子プロセスの
  # コードが来る。
  exit(0);
}

ただこれだけでは単に自分のコピーを作っているだけである。違ったことをさせるにしても、最初から親プロセスを設計する段階で何をさせるかはっきりわかっていなければいけないように思える。では、シェルのようなプログラムはどのようになっているのだろうか？これに対する答えが exec である。 exec は何をしているかというと、現在のプロセスイメージに新しいプロセスイメージを上書きする。だから、色々なプログラムを実行させるようにしたければ原理的には次のようにすると良い。

#!/usr/bin/perl

if( $#ARGV >= 0 ){
  @cmdline = @ARGV;
}else{
  @cmdline = ('/usr/games/fortune');
}

if( $pid = fork ) {
  print "I am the parent process. $$\n";
  print "pid is $pid.\n";
  exit(0);
}else{
  print "I am a child process. $$\n";
  print "pid is $pid.\n";
  print "Executing ", @cmdline, "\n";
  exec @cmdline;
  exit(0);
}

exit;

これは、コマンドラインから指定したコマンド (ただし、絶対パスで指定) を実行するだけのものである。 exec を使うことで、親プロセスの複製イメージに新たに起動したいプログラムのイメージを上書きすることで、別のプログラムを起動したかのように見える。実は UNIX の場合には『プログラムを起動する』というのは常にこのような手順を踏んでいるのである。さて、これを実行すると次のようになる。

host% perl fork2.pl
I am the parent process. 3292
I am a child process. 3293
pid is 0.
Executing /usr/games/fortune
pid is 3293.
host% We are going to give a little something, a few little years more, to
socialism, because socialism is defunct.  It dies all by itself.  The
bad thing is that socialism, being a victim of its ... Did I say
socialism?
                -- Fidel Castro

非同期に実行しているので、親プロセスは子プロセスの終了をまたず終了してしまうので、上のように不様な結果になる (子プロセスの出力がでる前に host% というシェルのプロンプトがでてしまうことに注意)。これの対策はあとで考えることにして、これでだいたいの子プロセス実行の原理が分かっただろう。さて、子プロセスの終了を親プロセスに待たせるには wait を使う。コードは次の通りである。

#!/usr/bin/perl

if( $#ARGV >= 0 ){
  @cmdline = @ARGV;
}else{
  @cmdline = ('/usr/games/fortune');
}

if( $pid = fork ) {
  print "I am the parent process. $$\n";
  print "pid is $pid.\n";
  $pid2 = wait;
  print "The child process has finished. $pid2\n";
  exit(0);
}else{
  print "I am a child process. $$\n";
  print "pid is $pid.\n";
  print "Executing ", @cmdline, "\n";
  exec @cmdline;
  exit(0);
}

exit;

こうすると、親プロセスが子プロセスの終了を待つようになる。これで単純なシェルが作れるはずだ。またこれは perl の system 関数の実装の仕方の原理でもある。なお、最後のスクリプトを実行してみると分かるが親プロセスの出力と子プロセスの出力がごっちゃになっている。これは、親プロセスのファイルハンドルは子プロセスに引き継がれるためである。詳しくはすぐ後に述べるが、このことは頭にいれておこう。

直接はソケットとは関係ないがこれを知っておくことは重要である。ファイルハンドルを扱うこととソケットを扱うことはかなり似ているからである。前のセクションでは子プロセスの実行の仕方を見た。ここでは、親プロセスと子プロセスとでデータのやりとりをすることを考えて見る。例として子プロセスを実行して stdin に出力したデータの行頭に # をつけて stdout に出力するスクリプトを書いて見る。

#!/usr/bin/perl

use IO::Handle;

pipe( Child, Parent );

Parent->autoflush(1);

if( $pid = fork ) {
  close( Parent );
  open( STDIN, "<&Child" ) || die "open: $!";
  while( <> ){
    print "#$_";
  }
  close( Child );
}else{
  close( Child );
  open( STDOUT, ">&Parent" ) || die "open: $!";
  exec '/usr/games/fortune';
  exit(0);
}

exit;

最初の pipe に注意して欲しい。一般的な書式は次の通りである。

pipe( 読み込み用ハンドル, 書き込み用ハンドル )

従って、書き込み用ハンドルに書き込んだものは読み込み用ハンドルを使って読み出せる。ファイルハンドルは子プロセスにも引き継がれるためこのようにしてから子プロセスを呼び出せば、子プロセスが Parent に書き込めば親プロセスは Child から読み出せるのである。

また open の使い方にも注意する必要がある。ここで使っているのはファイルハンドルの二重化のためのオープンであり、システムコール的には dup2 と同じ使い方である。親プロセス側の

  open( STDIN, "<&Child" ) || die "open: $!";

は STDIN を Child に結びつけている。このことは Child から読み出せるものはあたかもキーボードから入力されたように見えるということである。一方

  open( STDOUT, ">&Parent" ) || die "open: $!";

は STDOUT を Parent に結びつけている。これは端末にプリントアウトされたものは Parent に書き込まれるということを意味している。そして、既に説明したように、 Parent に書き込まれたものは Child から読み出せるから、子プロセスが何かを端末にプリントアウトすればそれがまるまる親プロセスに入力される仕組みになっている。これがパイプの実装の原理である。

無論、通常の使用ではここまですることはない。 open を用いれば perl がパイプ機能を提供してくれる。ここで取り上げたのはその原理を理解するためのコードである。

最後に厄介だが子プロセスを実行するプログラムにとって必要なことがらを述べる。今までは理解を助けるためのサンプルコードだったから晦渋をさけるためにその処理をして来なかったが fork(2) システムコールで子プロセスを実行した場合には必ず wait(2) で回収しなければならない。ただし、親プロセスが子プロセスの終了をのんびり待つわけにはいかない。だったら、シェルからコマンドをひとつひとつ実行するのと同じことになってしまう。これでは反復処理の高価なエミュレーションを行っているのと変わりない。

しかし UNIX オペレーティングシステム、ことに BSD 系の UNIX には次のような仕組みが用意されている。実行した子プロセスが終了した時には親プロセスにシグナルが送られる。シグナルをキャッチした時点で wait(2) すればよい。これは割り込み処理なので、シグナルをキャッチしないときには親プロセスは親プロセスで自分の仕事に専念できる。ただ注意しなければならないのは割り込み処理であるだけにあまり複雑なことは出来ないということである。システムによっては割り込み処理中に wait(2) も出来ないこともある。これはプログラマにとっては悩みの種である。しかし、かっての MS-DOS のように int24 処理の失敗でシステム全体が崩壊するまでにはいかない。ユーザプロセスのレベルならセグメンテーションバイオレーションを起こして core を吐くだけである。

この処理を具体的に行うのにはシグナルハンドラを書けば良い。シグナルハンドラ自体は通常のサブルーチンを書くのと何ら変わりはない。大抵の場合には次のようなもので十分であり、スクリプトを理解する必要がなく単に動けば良いという向きは下のコードをコピーして使えば良い。

sub REAPER {
  $waitedpid = wait;
  $SIG{CHLD} = \&REAPER;
}

$SIG{CHLD} = \&REAPER;

REAPER というのがシグナルハンドラである。で、これを %SIG 連想配列に登録しておけば良い。

ではここでサンプルプログラムを作って見よう。子プロセスの実行の仕方とファイルハンドルの二重化の方法が分かったところで、簡単な並行型サーバを作る。このサーバはポート 2345 をブロックしていてリクエストがあればクライアントに fortune の出力を返すというばかばかしいものである。

#!/usr/bin/perl -Tw
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;

$| = 1;

my $EOL = "\015\012";
my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

logmsg "Fortune server started on port $port";

my $waitedpid = 0;
my $paddr;

sub REAPER {
  $waitedpid = wait;
  $SIG{CHLD} = \&REAPER;
  logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}

$SIG{CHLD} = \&REAPER;

for ( $waitedpid = 0;
     ($paddr = accept(Client,Server)) || $waitedpid;
     $waitedpid = 0, close Client)
{
  next if $waitedpid and not $paddr;
  my($port,$iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr,AF_INET);

  logmsg "connection from $name [",inet_ntoa($iaddr), "] at port $port";

  exec_fortune( $name );
}

sub exec_fortune {
  my ($name) = @_;

  my $pid;
  if (!defined($pid = fork)) {
    logmsg "cannot fork: $!";
    return;
  } elsif ($pid) {
    logmsg "begat $pid";
    return; # I'm the parent
  }
  # else I'm the child -- go spawn
  
  open(STDOUT, ">&Client")   || die "can't dup client to stdout";

  sleep(3);
  print "Hello there, $name, it's now ", scalar localtime, $EOL;  
  exec '/usr/games/fortune'  || confess "can't exec fortune: $!";
  exit;
}

サーバとしての実質的なサービスはサブルーチン exec_fortune の中で行っているので、上のコードをそのままコピーしてサブルーチンの中だけを書き換えれば別の用途の並行型サーバの出来上がりである。なお、上のスクリプト中で

  sleep(3);
  print "Hello there, $name, it's now ", scalar localtime, $EOL;

などと 3 秒間スリープさせているのはサーバの処理を故意に重く見せかけるためである。これは実験用なので、わざとそうしているだけの話で実際には必要ない。

次にパフォーマンスの実験のために専用のクライアントをお目にかけよう。矢継ぎ早にリクエストを送るだけのものである。

#!/usr/bin/perl -w
use strict;
use Socket;

my $max_client_num = 10;
my $client_num = 0;
my $waitedpid = 0;

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

sub REAPER {
  $waitedpid = wait;
  $SIG{CHLD} = \&REAPER;
  $client_num--;
}

$SIG{CHLD} = \&REAPER;

my $i;

for($i = 0 ; $i < 100 ; $i++ ){
  if( $client_num < $max_client_num ){

    my $pid;
    if (!defined($pid = fork)) {
      logmsg "cannot fork: $!";
    } elsif ($pid) {
      # Parent
      logmsg "forked a child process: $pid";
      $client_num++;
    } else {
      # Child
  
      my ($porto, $iaddr, $paddr, $proto, $line);

      $porto = 2345;
      $iaddr   = inet_aton('localhost')          || die "No localhost";
      $paddr   = sockaddr_in($porto, $iaddr);
      $proto   = getprotobyname('tcp');
      socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
      connect(SOCK, $paddr)                      || die "connect: $!";
      open( FH, ">fortune$i.log" )               || die "open: $!";
      while (defined($line = <SOCK>)) {
        print FH $line;
      }
      close (FH)   || die "close: $!";
      close (SOCK) || die "close: $!";
      exit;
    }
  } else {
    sleep(5);
  }
}

このクライアントはこれといって面白味のないものだが、これはマルチスレッド型のクライアントのシンプルな例である。これは子プロセスをどんどん実行していく。その子プロセスがサーバに対してリクエストを送る。各子プロセスはファイルにサーバが送って来たものを格納し終了する。いちどきには 10 以上の子プロセスを実行しないようにして、これを都合 100 回行う。もしも、現在実行している子プロセスが 10 ならこのクライアントは 5 秒間スリープする。

このクライアントでサーバに接続させたところ、かなり早いスピードでクライアントからのリクエストを処理した。これは並行型サーバのおそるべき性能を意味する。

では従来の反復型サーバではどうだろうか？そのために次のようなサーバを準備した。

#!/usr/bin/perl -Tw
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

$| = 1;

my $EOL = "\015\012";

my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "Fortune server started on port $port";

while(1){
  my $paddr = accept(Client,Server);
  my ($port, $iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr, AF_INET);

  logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";

  print Client "Hello there, $name, it's now ", scalar localtime, $EOL;  
  open( Fortune, "/usr/games/fortune |" ) || die "can't exec fortune: $!";

  while( <Fortune> ){
    print Client $_;
  }
  close( Fortune );
  close( Client );
  sleep(3);
}

このサーバは telnet コマンドで試して見るとまあまあよく動いているようだ。また処理を重く見せかけるために例によって 3 秒間のスリープをいれてある。実験として先程のおそるべきマルチスレッドクライアントで接続させたら、人間がその差を容易に識別できる位の差がついた。私のシステムの場合だと待ち行列の数が大きくとれたのかどうか知らないが、接続が拒否される事態にまではならなかった。しかし、すべてのシステムで待ち行列の数が大きいと保証されているわけではないので、待ち行列に頼るのは問題がある場合もあるかも知れない。場合によってはクライアントからのリクエストが拒絶される場合もあるだろう。

少なくとも手間をかけてもマルチスレッド型のサーバを書いた方がパフォーマンスが良くなることは確かである。しかも、パフォーマンスの向上率は数値ではなく体感出来る範囲なのだからあなどれない。

以上のことを踏まえてマルチスレッド版の proxy launcher を作成して見よう。ここまでくれば、雛型が作ってあるのでそれを流用すれば簡単に作ることができる。今度のバージョンはマルチスレッド化のほかにプロキシとユーザエージェントをファイルから読み込むようになっている。

#!/usr/bin/perl
use strict;
use Socket;
use Carp;

my $agent_list_file = './agenet.txt';
my $proxy_list_file = './proxylist.txt';

my ( @agentlist, @proxylist );
                     
open( Agents, "$agent_list_file" ) || die "open: $!";
while( <Agents> ){
  chop;
  next if /^\s*$/;
  next if /^#/;
  push( @agentlist, $_ );
}
close( Agents );

open( Proxies, "$proxy_list_file" ) || die "open: $!";
while( <Proxies> ){
  chop;
  next if /^\s*$/;
  next if /^#/;
  s/\s//g;
  push( @proxylist, $_ );
}
close( Proxies );

sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

$| = 1;
my $EOL = "\015\012";
my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "perlgab server started on port $port";

my $max_client_num = 30;
my $client_num = 0;
my $waitedpid = 0;
my $paddr;

sub REAPER {
  $waitedpid = wait;
  $SIG{CHLD} = \&REAPER;
  $client_num--;
  logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}

$SIG{CHLD} = \&REAPER;

for ( $waitedpid = 0;
     ($paddr = accept(Client,Server)) || $waitedpid;
     $waitedpid = 0, close Client)
{
  next if $waitedpid and not $paddr;
  my($port,$iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr,AF_INET);

  logmsg "connection from $name [",inet_ntoa($iaddr), "] at port $port";

  if( $name ne 'localhost' ){
    print Client "I cannot talk with you. Sorry.$EOL";
    logmsg "connection refused from $name [", inet_ntoa($iaddr), "] at port $port";
  } else {
    while( $client_num >= $max_client_num ){
      sleep(1);
    }
    exec_child();
  }
}

sub exec_child {
  my $pid;
  
  if (!defined($pid = fork)) {
    logmsg "cannot fork: $!";
    return;
  } elsif ($pid) {
    logmsg "begat $pid";
    $client_num++;
    return; # Parent
  }
  # Child
  
  perlgab();
  exit;
}

sub perlgab {
  my $clienttext;
  my $contentlength = 0;
  my $entitybody;
  my $retbuff;

  srand;

  while( <Client> ){
    $clienttext .= $_;
    if( /^Content-length: (\d+)/ ){ $contentlength = $1 }
    last if( /^\015/ );
  }
  if( $contentlength ){
    read( Client, $entitybody, $contentlength );
    $clienttext .= $entitybody;
  }
  $clienttext = fake_user_agent($clienttext);
  $retbuff = send_request($clienttext);
  print Client $retbuff;
  close(Client)                                       || die "close: $!";
}

sub fake_user_agent {
  my ($buff) = @_;
  my $agent = $agentlist[int(rand($#agentlist+1))];

  $buff =~ s/User-Agent: [^\012\015]+/User-Agent: $agent/;
  return $buff;
}

sub send_request {
  my ($buff) = @_;
  my ($proxy, $proxyport) = split(':', $proxylist[int(rand($#proxylist+1))]);
  my ($iaddr, $paddr, $proto, $line);
  my $tmp = '';

  $iaddr   = inet_aton($proxy)                || die "host not found: $proxy";
  $paddr   = sockaddr_in($proxyport, $iaddr);

  $proto   = getprotobyname('tcp');
  socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
  connect(SOCK, $paddr)                      || die "connect: $!";

  logmsg "connecting to $proxy at port $proxyport";
  
  select(SOCK); $| = 1 ; select(STDOUT);
  print SOCK $buff;

  while (defined($line = <SOCK>)) {
     $tmp .= $line;
  }

  close (SOCK)                                || die "close: $!";
  return $tmp;
}

これはブラウザのプロキシの設定のところで指定して使う。ただ、プロキシサーバが接続を拒否したりした場合にはそのままなので、プロキシサーバが接続を拒否したら別のプロキシにつなぐような工夫が必要かも知れない。しかし、それは割合と簡単な練習問題なのでそのままにしておく。他の問題点として、転送中にブラウザの停止ボタンをクリックするといくつかプロセスが残ってしまう不具合が存在する。これは、タイムアウトを適当に設定して $SIG{ALRM} で exit するようにすると良い。これを行うには perlgab サブルーチンの最初のところを

  srand;

  $SIG{ALRM} = sub { die "$$: time out." };
  alarm( 10*60 );
  
  while( <Client> ){

などと変更すれば良いだろう。上の場合には 10 分でタイムアウトして子プロセスは終了する。

実際にネットワークにつないで実験したところ、特にマルチスレッド化による速度の向上は見られなかった。しかし、接続を拒否されたり、 pipe broken が起きてもサーバ自体はきちんと処理を続けることが出来た。

思い付きとして、イメージタグで指定された cgi の起動を防ぐようなフィルターをかけたり、 telnet や news などを使って IP アドレスを抜こうとするトラップには、そのような文字列をこのサーバで削除させることで対抗することが出来る。あるいは、 html をまるまる plain text ファイルにしたりすることも出来る。アイディア次第で普段使いなれたブラウザをそのまま用いて色々な面白いことが出来ることを付け加えておく。

いよいよ仕上げにはいる。現在の状態のままでもまあまあ使いものにはなるが、本格的な daemon プロセスとしての体裁を整えることにする。今までのままだと、サーバを起動すると端末を一つ占拠してしまう。もちろん、現在のように何らかのウィンドウシステムが利用できる状況ではそれでも構わないし、デバッグ中はそのほうが都合が良いこともある。しかし、出来れば普段は諸々の難しいことはファイルに記録させてサーバの存在自体を忘れてネットサーフィンにいそしみたいものだ。

そのために、まず daemon 化ということをすることにする。これは要するに端末を使わないようにしてルートディレクトリに移動してからサーバの常駐部分を切り離すことを意味する。ルートディレクトリに移動するのは起動したファイルシステムのあるディスクをアンマウントする際にサーバを停止させない限りファイルシステムがアンマウントできないからだ。もしも UNIX システムがあり、root の権限が使えるのなら適当な CD-ROM を用意して次のことを試みてみると良い。

host# mount /cdrom
host# cd /cdrom
host# umount /cdrom

ファイルシステムは大抵の場合切り離せないはずだ。もちろん、ログファイルなどが切り離すべきファイルシステムにあった場合も同様だが、出来れば行儀良く振舞った方がよい。具体的には次のようなコードをスクリプトの初期化が終ったあたりにいれれば良い。

use POSIX 'setsid';

chdir '/'                    or die "Can't chdir to /: $!";
open STDIN, '/dev/null'      or die "Can't read /dev/null: $!";
open STDOUT, '>/dev/null'    or die "Can't write to /dev/null: $!";
defined(my $pid = fork)      or die "Can't fork: $!";
exit if $pid;
setsid                       or die "Can't start a new session: $!";
open STDERR, '>&STDOUT'      or die "Can't dup stdout: $!";

あらかじめオープンされている stdin, stdout, stderr などは全部オープンしなおして /dev/null にする。 /dev/null には何を書き込んでも捨てるし、読み込みのためにオープンしても何もでて来ない。こうすれば、このサーバを起動した端末にゴミのような意味不明なサーバからのメッセージが表示されないですむ。

defined(my $pid = fork)      or die "Can't fork: $!";
exit if $pid;
setsid                       or die "Can't start a new session: $!";

ここで行っているのはいわゆる常駐終了である。自分自身のコピーを作成して親プロセスなら即座に終了する。複製された子プロセスはプロセスグループのリーダになるべく setsid する。以上が daemon 化といわれる部分のコードである。まともなサーバはかならずこの手順を踏んで起動する。

次に行いたいのはログとりだろう。これは、いままで端末に表示したものを単純にファイルに書き出すだけでよい。しかし、今の場合には複数のプロセスが一つのファイルに書き込みのために殺到する可能性もある。これを解決するのはファイルをロックするのが一番良い。多少まともな UNIX ならば必ず合理的にファイルをロックする機構が備わっており、今の場合には FreeBSD を使っていることから flock を使うことにする。 Solaris の場合には SysV 系なのでデフォルトでは flock は使えない。ただし、SPARC コンパイラなどがインストールしてあれば BSD 互換ライブラリがインストールされるので利用できるし、それをエミュレートするライブラリのソースをネット上で見付けることも出来るかも知れない。使い方は次のような感じである。

use Fcntl ':flock'; # import LOCK_* constants

sub lock {
  flock(MBOX,LOCK_EX);
  # and, in case someone appended
  # while we were waiting...
  seek(MBOX, 0, 2);
}

sub unlock {
  flock(MBOX,LOCK_UN);
}

open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") or die "Can't open mailbox: $!";

lock();
print MBOX $msg,"\n\n";
unlock();

ところで上のコードで close がないが、私の環境の場合 close をしたらうまく行かなかった。いずれにしてもファイルハンドルはプロセスが終了したら自動的に close されるので、神経質に close することもないだろう。

以上のことから、ログとりサブルーチン logmsg を次のように変更する。

sub logmsg {
  open( Log, ">>$log_file" ) || die "open: $!";
  flock(Log, LOCK_EX);
  seek(Log, 0, 2);
  print Log "$0 $$: @_ at ", scalar localtime, "\n";
  flock(Log, LOCK_UN);
}

#!/usr/bin/perl
use strict;
use Socket;
use Carp;
use POSIX 'setsid';
use Fcntl ':flock';

my $agent_list_file = '/tmp/agenet.txt';
my $proxy_list_file = '/tmp/proxylist.txt';
my $log_file        = '/tmp/perlgab.log';

my ( @agentlist, @proxylist );
                     
open( Agents, "$agent_list_file" ) || die "open: $!";
while( <Agents> ){
  chop;
  next if /^\s*$/;
  next if /^#/;
  push( @agentlist, $_ );
}
close( Agents );

open( Proxies, "$proxy_list_file" ) || die "open: $!";
while( <Proxies> ){
  chop;
  next if /^\s*$/;
  next if /^#/;
  s/\s//g;
  push( @proxylist, $_ );
}
close( Proxies );

# daemonize 
chdir '/'                    or die "Can't chdir to /: $!";
open STDIN, '/dev/null'      or die "Can't read /dev/null: $!";
open STDOUT, '>/dev/null'    or die "Can't write to /dev/null: $!";
defined(my $pid = fork)      or die "Can't fork: $!";
exit if $pid;
setsid                       or die "Can't start a new session: $!";
open STDERR, '>&STDOUT'      or die "Can't dup stdout: $!";

sub logmsg {
  open( Log, ">>$log_file" ) || die "open: $!";
  flock(Log, LOCK_EX);
  seek(Log, 0, 2);
  print Log "$0 $$: @_ at ", scalar localtime, "\n";
  flock(Log, LOCK_UN);
}

my $EOL = "\015\012";
my $port = 2345;
my $proto = getprotobyname('tcp');

socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY))        || die "bind: $!";
listen(Server,SOMAXCONN)                            || die "listen: $!";

logmsg "perlgab server started on port $port";

my $max_client_num = 30;
my $client_num = 0;
my $waitedpid = 0;
my $paddr;

sub REAPER {
  $waitedpid = wait;
  $SIG{CHLD} = \&REAPER;
  $client_num--;
  logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}

$SIG{CHLD} = \&REAPER;

for ( $waitedpid = 0;
     ($paddr = accept(Client,Server)) || $waitedpid;
     $waitedpid = 0, close Client)
{
  next if $waitedpid and not $paddr;
  my($port,$iaddr) = sockaddr_in($paddr);
  my $name = gethostbyaddr($iaddr,AF_INET);

  logmsg "connection from $name [",inet_ntoa($iaddr), "] at port $port";

  if( $name ne 'localhost' ){
    print Client "I cannot talk with you. Sorry.$EOL";
    logmsg "connection refused from $name [", inet_ntoa($iaddr), "] at port $port";
  } else {
    while( $client_num >= $max_client_num ){
      sleep(1);
    }
    exec_child();
  }
}

sub exec_child {
  my $pid;
  
  if (!defined($pid = fork)) {
    logmsg "cannot fork: $!";
    return;
  } elsif ($pid) {
    logmsg "begat $pid";
    $client_num++;
    return; # Parent
  }
  # Child
  
  perlgab();
  exit;
}

sub perlgab {
  my $clienttext;
  my $contentlength = 0;
  my $entitybody;
  my $retbuff;

  srand;

  $SIG{ALRM} = sub { die "$$: time out." };
  alarm( 10*60 );

  while( <Client> ){
    $clienttext .= $_;
    if( /^Content-length: (\d+)/ ){ $contentlength = $1 }
    last if( /^\015/ );
  }
  if( $contentlength ){
    read( Client, $entitybody, $contentlength );
    $clienttext .= $entitybody;
  }
  $clienttext = fake_user_agent($clienttext);
  $retbuff = send_request($clienttext);
  print Client $retbuff;
  close(Client)                                       || die "close: $!";
}

sub fake_user_agent {
  my ($buff) = @_;
  my $agent = $agentlist[int(rand($#agentlist+1))];

  $buff =~ s/User-Agent: [^\012\015]+/User-Agent: $agent/;
  return $buff;
}

sub send_request {
  my ($buff) = @_;
  my ($proxy, $proxyport) = split(':', $proxylist[int(rand($#proxylist+1))]);
  my ($iaddr, $paddr, $proto, $line);
  my $tmp = '';

  $iaddr   = inet_aton($proxy)                || die "host not found: $proxy";
  $paddr   = sockaddr_in($proxyport, $iaddr);

  $proto   = getprotobyname('tcp');
  socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
  connect(SOCK, $paddr)                      || die "connect: $!";

  logmsg "connecting to $proxy at port $proxyport";
  
  select(SOCK); $| = 1 ; select(STDOUT);
  print SOCK $buff;

  while (defined($line = <SOCK>)) {
     $tmp .= $line;
  }

  close (SOCK)                                || die "close: $!";
  return $tmp;
}

コードはおせじにもきれいといえるものではないので、きれいなコードに書き直すのは練習問題にする。また、色々な拡張も考えられるがそれも練習問題としておく。なお、デバッグ中にリアルタイムにログを見たければ

Socket クッキング・ブック(第二巻サーバ編)

サーバのセットアップ

ブラウザのリクエストヘッダを調べる

コードの例

セキュリティ

Proxy Launcher を作る

コード

並行型サーバ

子プロセスの実行

パイプとファイルハンドルの二重化

シグナル

サンプルプログラムとパフォーマンス

マルチスレッド Proxy Launcher の作成

仕上げ

Socket クッキング・ブック(第二巻 サーバ編)