Changeset 9962

Show
Ignore:
Timestamp:
04/20/08 11:59:49 (5 years ago)
Author:
tokuhirom
Message:

サーバーはもはやコアの機能ではない。普通に web application として mod_perl や FastCGI の上でも動かしやすい構成にする。

Location:
lang/perl/Moxy/branches/CC
Files:
1 removed
4 modified
1 moved

Legend:

Unmodified
Added
Removed

  • lang/perl/Moxy/branches/CC/config.yaml

    r9960 r9962  
    11--- 
    22global: 
     3  timeout: 3 
    34  storage: 
    45    module: DBM_File 
    … …  
    78 
    89plugins: 
    9   - module: Server::HTTPProxy 
    10     config: 
    11       port: 5880 
    12       host: localhost 
    13       max_clients: 80 
    14       timeout: 10 
    1510  - module: Filter::ControlPanel 
    1611  - module: Filter::XMLisHTML 

  • lang/perl/Moxy/branches/CC/lib/Moxy.pm

    r9959 r9962  
    1313use Carp; 
    1414use Scalar::Util qw/blessed/; 
     15use URI; 
     16use HTML::Parser; 
     17use URI::Escape; 
     18use HTML::Entities; 
     19use Scalar::Util qw/blessed/; 
     20use LWP::UserAgent; 
     21use HTML::Entities; 
     22use URI::Escape; 
     23use MIME::Base64; 
     24use Params::Validate ':all'; 
     25use URI::Heuristic qw(uf_uristr); 
     26use File::Spec::Functions; 
     27use YAML; 
     28use HTTP::MobileAttribute plugins => [ 
     29    qw/CarrierLetter IS/, 
     30    { 
     31        module => 'Display', 
     32        config => { 
     33            DoCoMoMap => YAML::LoadFile( 
     34                catfile( 'assets', 'common', 'docomo-display-map.yaml' ) 
     35            ) 
     36        } 
     37    }, 
     38]; 
    1539 
    1640__PACKAGE__->load_components(qw/UAInfo Plaggerize Autocall::InjectMethod Context/); 
    … …  
    7296} 
    7397 
     98sub rewrite { 
     99    my ($base, $html, $url) = @_; 
     100 
     101    my $output = ''; 
     102    my $base_url = URI->new($url); 
     103    my $parser = HTML::Parser->new( 
     104        api_version   => 3, 
     105        start_h       => [ sub { 
     106            my ($tagname, $attr, $orig) = @_; 
     107 
     108            if ($tagname eq 'a' || $tagname eq 'A' || $tagname =~ /link/i) { 
     109                $output .= "<$tagname"; 
     110                my @parts; 
     111                my $href = delete $attr->{href}; 
     112                if ($href) { 
     113                    push @parts, 
     114                      sprintf( qq{href="$base?q=%s"}, 
     115                        uri_escape(URI->new($href)->abs($base_url)) ); 
     116                } 
     117                push @parts, map { sprintf qq{%s="%s"}, encode_entities($_), encode_entities($attr->{$_}) } keys %$attr; 
     118                $output .= " " . join " ", @parts; 
     119                $output .= ">"; 
     120            } elsif ($tagname =~ /form/i) { 
     121                $output .= "<$tagname"; 
     122                my @parts; 
     123                my $action = delete $attr->{action}; 
     124                if ($action) { 
     125                    push @parts, sprintf(qq{action="$base?q=%s"}, 
     126                        uri_escape(URI->new($action)->abs($base_url)) 
     127                    ); 
     128                } 
     129                push @parts, map { sprintf qq{$_="%s"}, encode_entities($attr->{$_}) } keys %$attr; 
     130                $output .= " " . join " ", @parts; 
     131                $output .= ">"; 
     132            } elsif ($tagname =~ /(img|script)/i) { 
     133                $output .= "<$tagname"; 
     134                my @parts; 
     135                my $src = delete $attr->{src}; 
     136                if ($src) { 
     137                    push @parts, sprintf(qq{src="$base?q=%s"}, 
     138                        uri_escape(URI->new($src)->abs($base_url)) 
     139                    ); 
     140                } 
     141                push @parts, map { sprintf qq{%s="%s"}, encode_entities($_), encode_entities($attr->{$_}) } grep !/^\/$/, keys %$attr; 
     142                $output .= " " . join " ", @parts; 
     143                $output .= ">"; 
     144            } else { 
     145                $output .= $orig; 
     146                return; 
     147            } 
     148        }, "tagname, attr, text" ], 
     149        end_h  => [ sub { $output .= shift }, "text"], 
     150        text_h => [ sub { $output .= shift }, "text"], 
     151    ); 
     152 
     153    $parser->boolean_attribute_value('__BOOLEAN__'); 
     154    $parser->parse($html); 
     155    $output; 
     156} 
     157 
     158sub render_control_panel { 
     159    my ($base, $current_url) = @_; 
     160 
     161    return sprintf(<<"...", encode_entities($current_url)); 
     162    <script> 
     163        window.onload = function () { 
     164            document.getElementById('moxy_url').focus(); 
     165        }; 
     166    </script> 
     167    <form method="get" action="$base"> 
     168        <input type="text" name="q" value="\%s" size="40" id="moxy_url" /> 
     169        <input type="submit" value="go" /> 
     170    </form> 
     171... 
     172} 
     173 
     174sub handle_request { 
     175    my $self = shift; 
     176    my %args = validate( 
     177        @_, 
     178        +{ 
     179            request => { isa => 'HTTP::Request' }, 
     180        } 
     181    ); 
     182 
     183    my $uri = URI->new($args{request}->uri); 
     184    $self->log(debug => "Request URI: $uri"); 
     185 
     186    my $base = $uri->clone; 
     187    $base->query_form({}); 
     188 
     189    my $auth_header = $args{request}->header('Authorization'); 
     190    $self->log(debug => "Authorization header: $auth_header"); 
     191    if ($auth_header =~ /^Basic (.+)$/) { 
     192        my $auth = decode_base64($1); 
     193        $self->log(debug => "auth: $auth"); 
     194        my $url = uf_uristr(+{$uri->query_form}->{q}); 
     195        $self->log(info => "REQUEST $auth, @{[ $url || '' ]}"); 
     196        my $response = $self->_make_response( 
     197            url      => $url, 
     198            request  => $args{request}, 
     199            base_url => $base, 
     200            user_id  => $auth, 
     201        ); 
     202        return $response; 
     203    } else { 
     204        my $response = HTTP::Response->new(401, 'Moxy needs authentication'); 
     205        $response->header( 'WWW-Authenticate' => 
     206            qq{Basic realm="Moxy needs basic auth.Only for identification.Password is dummy."} 
     207        ); 
     208        $response->content('authentication required'); 
     209        return $response; 
     210    } 
     211} 
     212 
     213sub _make_response { 
     214    my $self = shift; 
     215    my %args = validate( 
     216        @_ => +{ 
     217            url      => qr{^https?://}, 
     218            request  => { isa  => 'HTTP::Request' }, 
     219            base_url => qr{^https?://}, 
     220            user_id  => { type => SCALAR }, 
     221        } 
     222    ); 
     223    my $url = $args{url}; 
     224    my $base_url = $args{base_url}; 
     225 
     226    if ($url) { 
     227        # do proxy 
     228        my $res = $self->_do_request( 
     229            url     => $url, 
     230            request => $args{request}, 
     231            user_id => $args{user_id}, 
     232        ); 
     233        $self->log(debug => '-- response status: ' . $res->code); 
     234 
     235        if ($res->code == 302) { 
     236            # rewrite redirect 
     237            my $location = URI->new($res->header('Location')); 
     238            my $uri = URI->new($url); 
     239            if ($uri->port != 80 && $location->port != $uri->port) { 
     240                $location->port($uri->port); 
     241            } 
     242            $res->header( 'Location' => $base_url . '?q=' 
     243                  . uri_escape( $location ) ); 
     244        } else { 
     245            my $content_type = $res->header('Content-Type'); 
     246            if ($content_type =~ /html/i) { 
     247                $res->content( rewrite($base_url, $res->content, $url) ); 
     248            } 
     249            use bytes; 
     250            $res->header('Content-Length' => bytes::length($res->content)); 
     251        } 
     252        return $res; 
     253    } else { 
     254        # please input url. 
     255        my $res = HTTP::Response->new(200, 'about:blank'); 
     256        $res->header('Content-Type' => 'text/html; charset=utf8'); 
     257        my $panel = render_control_panel($base_url, ''); 
     258        $res->content(qq{<html><head></head><body>$panel</body></html>}); 
     259        return $res; 
     260    } 
     261} 
     262 
     263sub _do_request { 
     264    my $self = shift; 
     265    my %args = validate( 
     266        @_ => +{ 
     267            url      => qr{^https?://}, 
     268            request  => { isa  => 'HTTP::Request' }, 
     269            user_id  => { type => SCALAR }, 
     270        } 
     271    ); 
     272 
     273    # make request 
     274    my $req = $args{request}->clone; 
     275    $req->uri($args{url}); 
     276    $req->header('Host' => URI->new($args{url})->host); 
     277 
     278    $self->run_hook( 
     279        'request_filter_process_agent', 
     280        {   request => $req, # HTTP::Request object 
     281            user    => $args{user_id}, 
     282        } 
     283    ); 
     284    my $mobile_attribute = HTTP::MobileAttribute->new($req->headers); 
     285    my $carrier = $mobile_attribute->carrier; 
     286    for my $hook ('request_filter', "request_filter_$carrier") { 
     287        my $response = $self->run_hook_and_get_response( 
     288            $hook, 
     289            +{ 
     290                request          => $req,              # HTTP::Request object 
     291                mobile_attribute => $mobile_attribute, 
     292                user             => $args{user_id}, 
     293            } 
     294        ); 
     295        if ($response) { 
     296            return $response; # finished 
     297        } 
     298    } 
     299 
     300    # do request 
     301    my $ua = LWP::UserAgent->new( 
     302        timeout           => $self->conf->{global}->{timeout} || 10, 
     303        max_redirects     => 0, 
     304        protocols_allowed => [qw/http https/], 
     305    ); 
     306    my $response = $ua->request($req); 
     307    for my $hook ( 'response_filter', "response_filter_$carrier" ) { 
     308        $self->run_hook( 
     309            $hook, 
     310            { 
     311                response         => $response,           # HTTP::Response object 
     312                mobile_attribute => $mobile_attribute, 
     313                user             => $args{user_id}, 
     314            } 
     315        ); 
     316    } 
     317    $response; 
     318} 
     319 
     320 
    743211; 
    75322__END__ 

  • lang/perl/Moxy/branches/CC/lib/Moxy/Server/HTTPProxy.pm

    r9960 r9962  
    1 package Moxy::Plugin::Server::HTTPProxy; 
     1package Moxy::Server::HTTPProxy; 
    22use strict; 
    33use warnings; 
    44use utf8; 
    5 use base qw/Class::Component::Plugin/; 
    6 use Moxy::Plugin::Server; 
    75use Encode; 
    86use HTTP::Proxy ':log'; 
    … …  
    1210use Carp; 
    1311 
    14 sub run_server:Method { 
    15     my ($self, $context, ) = @_; 
     12sub run { 
     13    my ($class, $context, $config, ) = @_; 
    1614 
    1715    $context->log(debug => "setup proxy server"); 
    18  
    19     my $config = $self->config->{config}; 
    2016 
    2117    my $proxy = HTTP::Proxy->new( 
    … …  
    2420        max_clients => $config->{max_clients}, 
    2521    ); 
    26  
    27     if ($config->{logmask}) { 
    28         my $bitmask = 0; 
    29         for my $const ( @{$config->{logmask}} ) { 
    30             $bitmask |= HTTP::Proxy->$const; 
    31         } 
    32         $proxy->logmask($bitmask); 
    33     } 
    3422 
    3523    $proxy->push_filter( 
    … …  
    4028                my ($filter, $x, $request) = @_; 
    4129                # $request is instance of HTTP::Request. 
    42                 my $response = handle_request( 
     30                my $response = $context->handle_request( 
    4331                    request => $request, 
    44                     context => $context, 
    45                     config  => $config, 
    4632                ); 
    4733                return $filter->proxy->response($response); 

  • lang/perl/Moxy/branches/CC/moxy.pl

    r2891 r9962  
    2222 
    2323my $conf_file = file( $FindBin::RealBin, 'config.yaml' )->stringify; 
     24my $server = 'HTTPProxy'; 
     25my $port = 5963; 
     26my $host = 'localhost'; 
    2427 
    2528Getopt::Long::GetOptions( 
    … …  
    2730    '--daemon'        => \my $daemon, 
    2831    '--config=s'      => \$conf_file, 
     32    '--server=s'      => \$server, 
     33    '--port=i'        => \$port, 
     34    '--host=i'        => \$host, 
     35    '--max-clients=i' => \my $max_clients, 
    2936) or pod2usage(2); 
    3037Getopt::Long::Configure("bundling"); 
    … …  
    3643sub start { 
    3744    my $moxy = Moxy->new($config); 
    38     $moxy->run; 
     45    my $server_module = "Moxy::Server::$server"; 
     46    $server_module->use or die $@; 
     47    $server_module->run( 
     48        $moxy => { 
     49            port        => $port, 
     50            host        => $host, 
     51            max_clients => $max_clients, 
     52        } 
     53    ); 
    3954} 
    4055 
    … …  
    6277        --config=s     => path to config file(default: config.yaml) 
    6378        --man          => show this manual 
     79        --server       => HTTPProxy or POE 
     80        --port         => default: 5963 
     81        --host         => default: localhost 
    6482 
    6583=head1 DESCRIPTION