unknownplace.org

今日の川上いいねぇ、ほれぼれするわぁ。

今日からワードリストを qw() でかく。いままでは qw// 。

なんとなく。

を書いた。会社のrepos内にアップしてしまったのでここに貼り付けちゃう。

#!/usr/bin/env perl

use strict;
use warnings;

use File::Spec;
use File::Find::Rule;
use FindBin;
use Getopt::Long;
use Pod::Usage;

use HTTP::Proxy;
use YAML;

# load config
my $config = do {
    my $config_file = File::Spec->catfile( $FindBin::Bin, 'config.yml' );
    my $port        = 0;
    my $host        = '';
    my $help        = 0;

    GetOptions(
        'port|p=s'   => \$port,
        'host|h=s'   => \$host,
        'config|c=s' => \$config_file,
        'help|?'     => \$help,
    );
    pod2usage(1) if $help;

    my $config = YAML::LoadFile($config_file);
    $config->{global} ||= {};
    $config->{global}{port} = $port if $port;
    $config->{global}{host} = $host if $host;

    $config;
};

my $proxy = HTTP::Proxy->new;
$proxy->port( $config->{global}{port} || 3000 );
$proxy->host( $config->{global}{host} || '' );

# find plugins
my %plugins;
for my $plugin_dir ( @{ $config->{global}{plugins_dir} } ) {
    my @files = File::Find::Rule->file->name('*.pm')->in($plugin_dir);
    for my $file (@files) {
        ( my $module = $file ) =~ s!(^$plugin_dir/?|\.pm$)!!g;
        $module =~ s!/!::!g;
        $plugins{"HTTP::Proxy::Plugin::$module"} = $file;
    }
}

# load and initialize plugins
for my $plugin ( @{ $config->{plugins} } ) {
    my $class = "HTTP::Proxy::Plugin::$plugin->{module}";
    my $file = $plugins{$class} || $class;

    eval { require "$file"; };
    die $@ if $@;

    my $module = $class->new( $plugin->{config} || {} );
    $module->register($proxy);
}

# set log levels
my $log_mask = 0;
for my $log_level (@{ $config->{global}{log}{mask} || [] }) {
    no strict 'refs';
    $log_mask |= &{"HTTP::Proxy::$log_level"};
}
$proxy->logmask($log_mask);

# start daemon
$proxy->start;

HTTP::Proxy自体がすばらしくて、perlユーザーであればこんなことものを使わなくても、自分でさくさくフィルタがかけるのであまり必要はなかったりする。

ただ再利用性とかperl知らない人用に考えると結構いい感じかもしれない。

プラグインの例:

package HTTP::Proxy::Plugin::Rewrite::Host;
use strict;
use warnings;
use base qw(HTTP::Proxy::HeaderFilter);

use List::Util qw(first);

sub new {
    my ( $class, $config ) = @_;
    my $self = bless { rewrites => $config }, $class;
}

sub register {
    my ( $self, $context ) = @_;
    $context->push_filter( request => $self );
}

sub filter {
    my ( $self, $content, $req ) = @_;

    my $host = first { $req->uri->host eq $_ } keys %{ $self->{rewrites} }
        or return;

    $host = $self->{rewrites}->{$host};

    if ($host and ref $host eq 'ARRAY') {
        my $path = $req->uri->path || '/';

        my $target = first { $path =~ /^$_->{path}/ } @$host
            or return;

        if ($target->{host}) {
            $path =~ s/^$target->{path}//;
            $req->uri->path( $path );
            $req->uri->host( $target->{host} );
        }
    }
    elsif ($host) {
        $req->uri->host($host);
    }
};

1;

特定のホストへのリクエストを別ホストへ転送するプラグイン

これを使う設定yamlはこんな感じ

global:
  host: ''
  port: 3000
  plugins_dir:
    - /home/typester/workdir/httpproxy/plugins
  log:
    mask:
      - ALL

plugins:
  - module: Rewrite::Host
    config:
      www.example.com: localhost:3001
      www2.example.com: localhost:3002
      www3.example.com:
        - path: /subbdir
          host: localhost:3003
        - path: /
          host: localhost:3004

これで

• www.example.com へのリクエストは localhost:3001 へのリクエストに
• www2.example.com へのリクエストは localhost:3002 へのリクエストに
• www3.example.com へのリクエストで、パスが /subdir* にマッチするものは localhost:3003 へ、それ以外は localhost:3004 へのリクエストに

なります。

パスみて変えるところはプラグインわけたほうがヨサゲではある。

追記@2006-09-15T14:43:21+09:00: plugin例が間違ってたので修正した。

Slimtimerのサイトからたどって発見したbuddlesというのを入れてみた。

これずっと欲しかったアプリだわぁ。Geckoベースなやつないかな。

出社。