メメメモモ

プログラミング、筋トレ、ゲーム、etc

トップ > perl > AnyEventでProxyサーバを書いてみた・・・けど

AnyEventでProxyサーバを書いてみた・・・けど

perl AnyEvent

http://gist.github.com/378947
AnyEvent::Socketを使ってProxyサーバを書いてみました。
けど、ちょっとまだ動作が不安定。
AnyEventを理解しきれていない感がたっぷりです。
AnyEvent::HTTPを使って書き直す予定。

use strict;
use warnings;

use AnyEvent;
use AnyEvent::Socket;
use AnyEvent::Handle;

my $proxy_port = 8080;

my %conn_table;
my %request;
my %stream;


my $cv = AnyEvent->condvar;


# Proxyサーバのイベントループ
my $guard; $guard = tcp_server undef, $proxy_port, sub {
    my ($sock, $host, $port) = @_;


    # ブラウザからのリクエストを読み込む

    
    sysread( $sock, my $request, 10000);
    if ( $request ) {
	print "   FROM Browser. Read OK.\n";
	print "\n";
	print $request;
	print "\n";
	$request{$sock} .= $request;

	if ( $request =~ m/\r\n\r\n|\n\n/ ) {
	    if ( $request =~ m/^(POST|GET) /) {

		# ブラウザからのリクエストを解析する

		my ($host, $port, $new_req, $method) =
		    parse_request($request);


		# ブラウザからのリクエストをWebサーバに送る
		$stream{$sock} = tcp_connect $host, $port, sub {
		    my ($sock_connect) = @_;


		    # Webサーバへのsocketが書き込みできるようになったらリクエストを送る
		    my $w_server; $w_server = AnyEvent->io(
			fh => $sock_connect,
			poll => 'w',
			cb => sub {
			    my $length = syswrite( $sock_connect, $new_req, length($new_req) ) || 0;

			    if ($length == length($new_req)) {
				undef $w_server;
			    }

			    # 1.リクエストに対するサーバからのレスポンスを受け取る
			    # 2.受け取ったらブラウザに送る

			    my $r;
			    my $res_cb = sub {
				my $length = sysread( $sock_connect, my $res, 10000 ) || 0;
				if ($length > 0) {
				    my $cli_sock = $sock;

				    my $w_browser; $w_browser = AnyEvent->io(
					fh => $cli_sock,
					poll => "w",
					cb => sub {
					    my $length = syswrite( $cli_sock, $res, length($res) ) || 0;

					    if ($length == length($res) || $length == 0) {
						undef $w_browser;
					    }
					});
				} else {
				    undef $r;
				}
			    };

			    $r = AnyEvent->io(
				fh => $sock_connect,
				poll => 'r',
				cb => $res_cb,
				);
			});
		};
	    }
	}
    }
};

$cv->recv;


sub parse_request {
    my ($req) = @_;
    my $host;
    my $port;
    my $new_req = '';
    my $r = '';

    my $is_header = 1;

    foreach ( split(/\r\n|\n/, $req, -1) ) {
	if ( m|^([A-Z]+) [a-zA-Z]+://(.*?)/(.*?) (HTTP/\d\.\d)$|i) {
	    my $proto_ver;
	    my $path;
	    my $method;
	    ($method, $host, $path, $proto_ver) = ($1, $2, $3, $4);

	    if ( $host =~ s/:(\d+)$// ) {
		$port = $1;
	    } else {
		$port = 80;
	    }
	    $new_req = "$method /$path $proto_ver\r\n";
	    $r = $new_req;
	} elsif ( $is_header ) {
	    if ( m/^(.*?):\s*(.*)$/s ) {
		my ($header, $value) = ($1, $2);
		$new_req .= "$header: $value\r\n";
	    } elsif ( $_ eq '' ) {
		$new_req .= "\r\n";
		$is_header = 0;
	    }
	} elsif ( ! $is_header ) {
	    $new_req .= "$_";
	}
    }

    return ($host, $port, $new_req, $r);
}

参考