Changeset 29266

Show
Ignore:
Timestamp:
01/30/09 12:21:15 (4 years ago)
Author:
yappo
Message:

svk sm branches/functional trunk

Location:
lang/perl/HTTP-Engine-Middleware/trunk
Files:
9 modified

Legend:

Unmodified
Added
Removed

  • lang/perl/HTTP-Engine-Middleware/trunk

  • lang/perl/HTTP-Engine-Middleware/trunk/lib/HTTP/Engine/Middleware/DoCoMoGUID.pm

    r11963 r29266  
    55 
    66sub wrap { 
    7     my ($next, $c) = @_; 
     7    my ($class, $next) = @_; 
    88     
    9     $next->($c); 
     9    sub { 
     10        my $req = shift; 
    1011 
    11     if (   $c->res->status == 200 
    12         && $c->res->content_type =~ /html/ 
    13         && not blessed $c->res->body 
    14         && $c->res->body ) 
    15     { 
    16         my $body = $c->res->body; 
    17         $c->res->body( 
    18             do { 
    19                 my $guid = HTML::StickyQuery->new( 
    20                     'abs' => 1, 
    21                 ); 
    22                 $guid->sticky( 
    23                     scalarref => \$body, 
    24                     param     => { guid => 'ON' }, 
    25                 ); 
    26             } 
    27         ); 
     12        my $res = $next->($req); 
     13 
     14        if (   $res->status == 200 
     15            && $res->content_type =~ /html/ 
     16            && not blessed $res->body 
     17            && $res->body ) 
     18        { 
     19            my $body = $res->body; 
     20            $res->body( 
     21                sub { 
     22                    my $guid = HTML::StickyQuery->new( 
     23                        'abs' => 1, 
     24                    ); 
     25                    $guid->sticky( 
     26                        scalarref => \$body, 
     27                        param     => { guid => 'ON' }, 
     28                    ); 
     29                }->() 
     30            ); 
     31        } 
     32 
     33        $res; 
    2834    } 
    2935} 

  • lang/perl/HTTP-Engine-Middleware/trunk/lib/HTTP/Engine/Middleware/Encode.pm

    r11888 r29266  
    55 
    66sub wrap { 
    7     my ($next, $c) = @_; 
     7    my ($class, $next) = @_; 
    88 
    9     if (($c->req->headers->header('Content-Type')||'') =~ /charset=(.+);?$/) { 
    10         # decode parameters 
    11         my $encoding = $1; 
    12         my $dve = Data::Visitor::Encode->new; 
    13         $c->req->query_parameters($dve->decode($encoding, $c->req->query_parameters)); 
    14         $c->req->body_parameters($dve->decode($encoding, $c->req->body_parameters)); 
    15         $c->req->parameters($dve->decode($encoding, $c->req->parameters)); 
    16     } 
     9    sub { 
     10        my $req = shift; 
     11        if (($req->headers->header('Content-Type')||'') =~ /charset=(.+);?$/) { 
     12            # decode parameters 
     13            my $encoding = $1; 
     14            for my $method (qw/params query_params body_params/) { 
     15                $req->$method( Data::Visitor::Encode->decode($encoding, $req->$method) ); 
     16            } 
    1717 
    18     $next->($c); 
     18            $next->($req); 
     19        } 
     20    }; 
    1921} 
    2022 
    21  
    22231; 

  • lang/perl/HTTP-Engine-Middleware/trunk/lib/HTTP/Engine/Middleware/ModuleReload.pm

    r11881 r29266  
    44 
    55sub wrap { 
    6     my $next = shift; 
     6    my ($class, $next) = shift; 
    77 
    8     Module::Reload->check; 
     8    sub { 
     9        my $req = shift; 
     10        Module::Reload->check; 
    911 
    10     $next->(@_); 
     12        $next->($req); 
     13    }; 
    1114} 
    1215 

  • lang/perl/HTTP-Engine-Middleware/trunk/lib/HTTP/Engine/Middleware/ReverseProxy.pm

    r11881 r29266  
    33 
    44sub wrap { 
    5     my ($next, $c) = @_; 
     5    my ($class, $next) = @_; 
    66 
    7     # in apache httpd.conf (RequestHeader set X-Forwarded-HTTPS %{HTTPS}s) 
    8     $ENV{HTTPS} = $ENV{HTTP_X_FORWARDED_HTTPS} if $ENV{HTTP_X_FORWARDED_HTTPS}; 
    9     $ENV{HTTPS} = 'ON'                         if $ENV{HTTP_X_FORWARDED_PROTO}; # Pound 
    10     $c->req->secure(1) if $ENV{HTTPS} && uc $ENV{HTTPS} eq 'ON'; 
     7    sub { 
     8        my $req = shift; 
    119 
    12     # If we are running as a backend server, the user will always appear 
    13     # as 127.0.0.1. Select the most recent upstream IP (last in the list) 
    14     if ($ENV{HTTP_X_FORWARDED_FOR}) { 
    15         my ($ip, ) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; 
    16         $c->req->address($ip); 
    17     } 
     10        my $env = $req->_connection->{env} || {}; 
     11        # in apache httpd.conf (RequestHeader set X-Forwarded-HTTPS %{HTTPS}s) 
     12        $env->{HTTPS} = $req->headers->{'x-forwarded-https'} if $req->headers->{'x-forwarded-https'}; 
     13        $env->{HTTPS} = 'ON'                         if $req->headers->{'x-forwarded-proto'}; # Pound 
     14        $req->secure(1) if $env->{HTTPS} && uc $env->{HTTPS} eq 'ON'; 
    1815 
    19     if ($ENV{HTTP_X_FORWARDED_HOST}) { 
    20         my $host = $ENV{HTTP_X_FORWARDED_HOST}; 
    21         if ($host =~ /^(.+):(\d+)$/ ) { 
    22             $host = $1; 
    23             $ENV{SERVER_PORT} = $2; 
    24         } elsif ($ENV{HTTP_X_FORWARDED_PORT}) { 
    25             # in apache httpd.conf (RequestHeader set X-Forwarded-Port 8443) 
    26             $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT}; 
     16        # If we are running as a backend server, the user will always appear 
     17        # as 127.0.0.1. Select the most recent upstream IP (last in the list) 
     18        if ($req->headers->{'x-forwarded-for'}) { 
     19            my ($ip, ) = $req->headers->{'x-forwarded-for'} =~ /([^,\s]+)$/; 
     20            $req->address($ip); 
    2721        } 
    28         $ENV{HTTP_HOST} = $host; 
    2922 
    30         $c->req->headers->header( 'Host' => $ENV{HTTP_HOST} ); 
    31     } 
     23        if ($req->headers->{'x-forwarded-host'}) { 
     24            my $host = $req->headers->{'x-forwarded-host'}; 
     25            if ($host =~ /^(.+):(\d+)$/ ) { 
     26                $host = $1; 
     27                $env->{SERVER_PORT} = $2; 
     28            } elsif ($req->headers->{'x-forwarded-port'}) { 
     29                # in apache httpd.conf (RequestHeader set X-Forwarded-Port 8443) 
     30                $env->{SERVER_PORT} = $req->headers->{'x-forwarded-port'}; 
     31            } 
     32            $env->{HTTP_HOST} = $host; 
    3233 
    33     for my $attr (qw/uri base/) { 
    34         my $scheme = $c->req->secure ? 'https' : 'http'; 
    35         my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; 
    36         my $port = $ENV{SERVER_PORT} || ( $c->req->secure ? 443 : 80 ); 
     34            $req->headers->header( 'Host' => $env->{HTTP_HOST} ); 
     35        } 
     36        $req->_connection->{env} = $env; 
    3737 
    38         $c->req->$attr->scheme($scheme); 
    39         $c->req->$attr->host($host); 
    40         $c->req->$attr->port($port); 
    41         $c->req->$attr( $c->req->$attr->canonical ); 
    42     } 
     38        for my $attr (qw/uri base/) { 
     39            my $scheme = $req->secure ? 'https' : 'http'; 
     40            my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME}; 
     41            my $port = $env->{SERVER_PORT} || ( $req->secure ? 443 : 80 ); 
     42            # my $path_info = $env->{PATH_INFO} || '/'; 
    4343 
    44     $next->($c); 
     44            $req->$attr->scheme($scheme); 
     45            $req->$attr->host($host); 
     46            $req->$attr->port($port); 
     47            # $req->$attr->path($path_info); 
     48            # $req->$attr( $req->$attr->canonical ); 
     49        } 
     50        $next->($req); 
     51    }; 
    4552} 
    4653 

  • lang/perl/HTTP-Engine-Middleware/trunk/t/01_encode.t

    r12846 r29266  
    55eval q{ use Data::Visitor::Encode }; 
    66plan skip_all => "Data::Visitor::Encode is not installed" if $@; 
    7 eval q{ use HTTP::Engine middlewares => ['+HTTP::Engine::Middleware::Encode'] }; 
     7eval q{ use HTTP::Request }; 
     8plan skip_all => "HTTP::Request is not installed" if $@; 
     9eval q{ use HTTP::Engine }; 
    810plan skip_all => "HTTP::Engine is not installed: $@" if $@; 
     11 
     12eval q{ use HTTP::Engine::Middleware::Encode }; 
    913 
    1014plan tests => 3*blocks; 
    … …  
    2226    my $request = HTTP::Request->new( GET => $block->uri, ['Content-Type' => $block->content_type] ); 
    2327 
     28    my $do_test = sub { 
     29        my $req = shift; 
     30        ok Encode::is_utf8($req->params->{'nite'}); 
     31        is_deeply $req->params, $block->params, $block->name; 
     32        HTTP::Engine::Response->new(body => 'OK!'); 
     33    }; 
     34 
    2435    my $response = HTTP::Engine->new( 
    2536        interface => { 
    2637            module => 'Test', 
    27             request_handler => sub { 
    28                 my $c = shift; 
    29                 ok Encode::is_utf8($c->req->params->{'nite'}); 
    30                 is_deeply $c->req->params, $block->params, $block->name; 
    31                 $c->res->body('OK!'); 
    32             }, 
     38            request_handler => HTTP::Engine::Middleware::Encode->wrap($do_test), 
    3339        }, 
    3440    )->run($request); 

  • lang/perl/HTTP-Engine-Middleware/trunk/t/02_docomo_guid.t

    r11963 r29266  
    44use lib '.'; 
    55use Test::Base; 
    6 eval q{ use HTTP::Engine middlewares => ['+HTTP::Engine::Middleware::DoCoMoGUID'] }; 
    7 plan skip_all => "some depended module is not installed.: $@" if $@; 
     6eval q{ use HTML::StickyQuery }; 
     7plan skip_all => "HTML::StickyQuery is not installed" if $@; 
     8eval q{ use HTTP::Engine }; 
     9plan skip_all => "HTTP::Engine is not installed: $@" if $@; 
    810 
    911plan tests => 1*blocks; 
    … …  
    1113use Encode; 
    1214use URI; 
     15use HTTP::Request; 
     16use HTTP::Engine::Response; 
     17eval q{ use HTTP::Engine::Middleware::DoCoMoGUID }; 
     18 
     19filters({ 
     20    expected  => qw/ chomp /, 
     21}); 
    1322 
    1423run { 
    1524    my $block = shift; 
    1625 
     26    my $code = sub { 
     27        my $req = shift; 
     28        HTTP::Engine::Response->new( 
     29          content_type  => 'text/html', 
     30          body          => $block->input, 
     31        ); 
     32    }; 
     33 
    1734    my $response = HTTP::Engine->new( 
    1835        interface => { 
    1936            module => 'Test', 
    20             request_handler => sub { 
    21                 my $c = shift; 
    22                 $c->res->content_type('text/html'); 
    23                 $c->res->body($block->input); 
    24             }, 
     37            request_handler => HTTP::Engine::Middleware::DoCoMoGUID->wrap($code), 
    2538        }, 
    2639    )->run(HTTP::Request->new( GET => '/' )); 
    … …  
    3447--- input 
    3548<a href="/foo">bar</a> 
    36 --- expected: <a href="/foo?guid=ON">bar</a> 
    37  
     49--- expected 
     50<a href="/foo?guid=ON">bar</a> 
    3851=== 
    3952--- input 
    4053<a href="http://192.168.1.3/?page=1">&lt; 2008-05-18</a> 
    41 --- expected: <a href="http://192.168.1.3/?page=1&amp;guid=ON">&lt; 2008-05-18</a> 
    42  
     54--- expected 
     55<a href="http://192.168.1.3/?page=1&amp;guid=ON">&lt; 2008-05-18</a> 

  • lang/perl/HTTP-Engine-Middleware/trunk/t/12_plugin_mobile_attribute.t

    r11960 r29266  
    22use warnings; 
    33use Test::More; 
     4 
     5eval { 
     6    require HTTP::Engine; 
     7}; 
     8plan skip_all => "HTTP::Engine is not installed." if $@; 
    49 
    510eval { 
    … …  
    1318HTTP::Engine::Middleware::MobileAttribute->setup(); 
    1419 
    15 { 
    16     my $req = HTTP::Engine::Request->new(); 
     20sub do_test { 
     21    my $coderef = shift; 
     22 
     23    HTTP::Engine->new( 
     24        interface => { 
     25            module  => 'Test', 
     26            request_handler => sub { 
     27                my $req = shift; 
     28 
     29                $coderef->($req); 
     30 
     31                HTTP::Engine::Response->new(body => 'OK'); 
     32            }, 
     33        }, 
     34    )->run(HTTP::Request->new(GET => 'http://example.org')); 
     35} 
     36 
     37do_test(sub { 
     38    my $req = shift; 
    1739    $req->user_agent('IE'); 
    1840    isa_ok $req->mobile_attribute, 'HTTP::MobileAttribute::Agent::NonMobile'; 
    19 } 
     41}); 
    2042 
    21 { 
    22     my $req = HTTP::Engine::Request->new(); 
     43do_test(sub { 
     44    my $req = shift; 
    2345    $req->user_agent('DoCoMo/1.0/D501i'); 
    2446    isa_ok $req->mobile_attribute, 'HTTP::MobileAttribute::Agent::DoCoMo'; 
    25 } 
     47}); 
    2648 

  • lang/perl/HTTP-Engine-Middleware/trunk/t/15_middleware_reverseproxy.t

    r11960 r29266  
    22use warnings; 
    33use Test::Base; 
    4 use HTTP::Engine middlewares => [ 
    5     qw/ReverseProxy/ 
    6 ]; 
     4use HTTP::Engine; 
     5use HTTP::Engine::Middleware::ReverseProxy; 
     6use HTTP::Request; 
     7use HTTP::Headers; 
    78 
    89filters { input => [qw/yaml/] }; 
    910 
    10 plan tests => 23; 
     11plan tests => 17; 
    1112 
    1213run { 
    1314    my $block = shift; 
    14     local %ENV = %{ $block->input }; 
     15    local %ENV = (); 
    1516    $ENV{REMOTE_ADDR}    = '127.0.0.1'; 
    1617    $ENV{REQUEST_METHOD} = 'GET'; 
    … …  
    1920    $ENV{QUERY_STRING}   = 'foo=bar'; 
    2021 
     22    my $headers = HTTP::Headers->new; 
     23    $headers->header(%{ $block->input }); 
     24    # $headers->header(HOST => 'example.com:80'); 
    2125    HTTP::Engine->new( 
    2226        interface => { 
    23             module => 'CGI', 
    24             request_handler => sub { 
    25                 my $c = shift; 
    26                 eval $block->expected; 
    27                 die $@ if $@; 
    28             }, 
     27            module => 'Test', 
     28            request_handler => HTTP::Engine::Middleware::ReverseProxy->wrap(sub { 
     29                my $req = shift; 
     30 
     31                for my $attr ( qw/secure address/ ) { 
     32                    if ( $block->$attr ) { 
     33                      is($req->$attr, $block->$attr, $block->name . " of $attr"); 
     34                    } 
     35                } 
     36                for my $url ( qw/uri base / ) { 
     37                  if ( $block->$url ) { 
     38                    is($req->$url->as_string, $block->$url, $block->name . " of $url"); 
     39                  } 
     40                } 
     41 
     42                HTTP::Engine::Response->new(body  => 'OK'); 
     43            }), 
    2944        }, 
    30     )->run; 
     45    )->run(HTTP::Request->new(GET => 'http://example.com/?foo=bar', $headers),env => \%ENV); 
    3146}; 
    3247 
    3348__END__ 
    3449 
    35 === 
     50=== with https 
    3651--- input 
    37 HTTP_X_FORWARDED_HTTPS: ON 
    38 --- expected 
    39 is $c->req->secure, 1; 
    40 is $c->req->uri->as_string, "https://example.com:80?foo=bar"; 
    41 is $c->req->base->as_string, "https://example.com:80/"; 
     52x-forwarded-https: on 
     53--- secure: 1 
     54--- base: https://example.com:80/ 
     55--- uri:  https://example.com:80/?foo=bar 
     56 
     57=== without https 
     58--- input 
     59x-forwarded-https: off 
     60--- secure: 0 
     61--- base: http://example.com:80/ 
     62--- uri:  http://example.com:80/?foo=bar 
    4263 
    4364=== 
    4465--- input 
    45 HTTP_X_FORWARDED_HTTPS: OFF 
    46 --- expected 
    47 is $c->req->secure, 0; 
    48 is $c->req->uri->as_string, "http://example.com?foo=bar"; 
    49 is $c->req->base->as_string, "http://example.com/"; 
     66dummy: 1 
     67--- secure: 0 
     68--- base: http://example.com:80/ 
     69--- uri: http://example.com:80/?foo=bar 
    5070 
    51 === 
     71=== https with HTTP_X_FORWARDED_PROTO 
    5272--- input 
    53 DUMMY: 1 
    54 --- expected 
    55 is $c->req->secure, 0; 
    56 is $c->req->uri->as_string, "http://example.com?foo=bar"; 
    57 is $c->req->base->as_string, "http://example.com/"; 
     73x-forwarded-proto: https 
     74--- secure: 1 
     75--- base: https://example.com:80/ 
     76--- uri:  https://example.com:80/?foo=bar 
    5877 
    59 === 
     78=== with HTTP_X_FORWARDED_FOR 
    6079--- input 
    61 HTTP_X_FORWARDED_PROTO: https 
    62 --- expected 
    63 is $c->req->secure, 1; 
    64 is $c->req->uri->as_string, "https://example.com:80?foo=bar"; 
    65 is $c->req->base->as_string, "https://example.com:80/"; 
     80x-forwarded-for: 192.168.3.2 
     81--- address: 192.168.3.2 
     82--- base: http://example.com:80/ 
     83--- uri:  http://example.com:80/?foo=bar 
    6684 
    67 === 
     85=== with HTTP_X_FORWARDED_HOST 
    6886--- input 
    69 HTTP_X_FORWARDED_FOR: 192.168.3.2 
    70 --- expected 
    71 is $c->req->address, '192.168.3.2'; 
    72 is $c->req->uri->as_string, "http://example.com?foo=bar"; 
    73 is $c->req->base->as_string, "http://example.com/"; 
     87x-forwarded-host: 192.168.1.2:5235 
     88--- base: http://192.168.1.2:5235/ 
     89--- uri:  http://192.168.1.2:5235/?foo=bar 
    7490 
    75 === 
     91=== with HTTP_X_FORWARDED_HOST and HTTP_X_FORWARDED_PORT 
    7692--- input 
    77 HTTP_X_FORWARDED_HOST: 192.168.1.2:5235 
    78 --- expected 
    79 is $ENV{HTTP_HOST}, '192.168.1.2'; 
    80 is $ENV{SERVER_PORT}, 5235; 
    81 is $c->req->uri->as_string, "http://192.168.1.2:5235?foo=bar"; 
    82 is $c->req->base->as_string, "http://192.168.1.2:5235/"; 
     93x-forwarded-host: 192.168.1.5 
     94x-forwarded-port: 1984 
     95--- base: http://192.168.1.5:1984/ 
     96--- uri:  http://192.168.1.5:1984/?foo=bar 
    8397 
    84 === 
    85 --- input 
    86 HTTP_X_FORWARDED_HOST: 192.168.1.5 
    87 HTTP_X_FORWARDED_PORT: 1984 
    88 --- expected 
    89 is $ENV{HTTP_HOST}, '192.168.1.5'; 
    90 is $ENV{SERVER_PORT}, 1984; 
    91 is $c->req->uri->as_string, "http://192.168.1.5:1984?foo=bar"; 
    92 is $c->req->base->as_string, "http://192.168.1.5:1984/"; 
    93