root/lang/perl/Moxy/trunk/lib/Moxy/Plugin/Application.pm @ 4971

Revision 4971, 7.7 kB (checked in by tokuhirom, 5 years ago)

Moxy::Plugin::Application の挙動を大幅に変更。Moxy(Application) が
Moxy(Proxy) に対してリクエストするという仕様から、Moxy(Application)
自体がターゲットサイトに直接リクエスト送るようにした。これは ssb と同じ
挙動。

Line 
1package Moxy::Plugin::Application;
2use strict;
3use warnings;
4use LWP::UserAgent;
5use URI;
6use HTML::Parser;
7use HTML::Entities;
8use URI::Escape;
9use MIME::Base64;
10
11our $TIMEOUT = 10;
12
13# TODO: support https
14
15sub register {
16    my ($class, $context) = @_;
17
18    my $base_host = $context->config->{global}->{application}->{host};
19    my $base_port = $context->config->{global}->{application}->{port};
20    my $base = "http://$base_host:$base_port/";
21
22    $context->register_hook(
23        request_filter_before_auth => sub {
24            my ($context, $args) = @_;
25
26            my $uri = URI->new($args->{request}->uri);
27            $context->log(debug => "Request URI: $uri");
28
29            if ( $uri->host eq $base_host && ($uri->port||80) == $base_port) {
30                my $auth_header = $args->{request}->header('Authorization');
31                $context->log(debug => "Authorization header: $auth_header");
32                if ($auth_header =~ /^Basic (.+)$/) {
33                    my $auth = decode_base64($1);
34                    $context->log(debug => "auth: $auth");
35                    my $url = +{$uri->query_form}->{q};
36                    $context->log(info => "REQUEST $auth, @{[ $url || '' ]}");
37                    my $response =
38                      $class->_make_response( $context, $url, $args->{request},
39                        $base, $auth );
40                    return $response;
41                } else {
42                    my $response = HTTP::Response->new(401, 'Moxy needs authentication');
43                    $response->header( 'WWW-Authenticate' =>
44qq{Basic realm="Moxy needs basic auth.Only for identification.Password is dummy."}
45                    );
46                    $response->content('authentication required');
47                    return $response;
48                }
49            }
50            return; # DECLINED
51        },
52        control_panel => sub {
53            my ($context, $args) = @_;
54
55            return $class->_render_control_panel($base, $args->{response}->request->uri);
56        },
57    );
58}
59
60sub _render_control_panel {
61    my ($class, $base, $current_url) = @_;
62
63    return sprintf(<<"...", encode_entities($current_url));
64    <form method="get" action="$base">
65        <input type="text" name="q" value="\%s" size="40" />
66        <input type="submit" value="go" />
67    </form>
68...
69}
70
71sub _ua {
72    my ($class, $proxy_url) = @_;
73
74    my $ua = LWP::UserAgent->new(
75        timeout       => $TIMEOUT,
76        max_redirects => 0,
77    );
78    $ua;
79}
80
81sub _make_response {
82    my ($class, $context, $url, $src_req, $base, $auth) = @_;
83
84    if ($url) {
85        # do proxy
86        my $res = $class->do_request($context, $src_req, $url, $auth);
87        $context->log(debug => '-- response status: ' . $res->code);
88
89        if ($res->code == 302) {
90            # rewrite redirect
91            $res->header( 'Location' => $base . '?q='
92                  . uri_escape( $res->header('Location') ) );
93        } else {
94            my $content_type = $res->header('Content-Type');
95            if ($content_type =~ /html/i) {
96                $res->content( _rewrite($base, $res->content, $url) );
97            }
98        }
99        return $res;
100    } else {
101        # please input url.
102        my $res = HTTP::Response->new(200, 'about:blank');
103        $res->header('Content-Type' => 'text/html; charset=utf8');
104        my $panel = $class->_render_control_panel($base, '');
105        $res->content(qq{<html><head></head><body>$panel</body></html>});
106        return $res;
107    }
108}
109
110sub do_request {
111    my ($class, $context, $src_req, $url, $auth) = @_;
112
113    # make request
114    my $req = $src_req->clone;
115    $req->uri($url);
116    $req->header('Host' => URI->new($url)->host);
117
118    $context->run_hook(
119        'request_filter_process_agent',
120        {   request => $req, # HTTP::Request object
121            user    => $auth,
122        }
123    );
124    my $agent = $context->get_ua_info($req->header('User-Agent'));
125    my $carrier = $agent->{agent} ? HTTP::MobileAgent->new($agent->{agent})->carrier : 'N';
126    for my $hook ('request_filter', "request_filter_$carrier") {
127        my $response = $context->run_hook_and_get_response(
128            $hook,
129            +{
130                request => $req,    # HTTP::Request object
131                agent   => $agent,
132                user    => $auth,
133            }
134        );
135        if ($response) {
136            return $response; # finished
137        }
138    }
139
140    # do request
141    my $ua = $class->_ua;
142    my $response = $ua->request($req);
143    my $bodyref = \($response->content);
144    my $response_filter = sub {
145        my $key = shift;
146        for my $hook ($key, "${key}_$carrier") {
147            $context->run_hook(
148                $hook,
149                {   response    => $response, # HTTP::Response object
150                    content_ref => $bodyref, # response body's scalarref.
151                    agent       => $agent,
152                    user        => $auth,
153                }
154            );
155        }
156    };
157    $response_filter->('response_filter');
158    $response_filter->('response_filter_header');
159    $response->content($$bodyref);
160    $response;
161}
162
163sub _rewrite {
164    my ($base, $html, $url) = @_;
165
166    my $output = '';
167    my $base_url = URI->new($url);
168    my $parser = HTML::Parser->new(
169        api_version   => 3,
170        start_h       => [ sub {
171            my ($tagname, $attr, $orig) = @_;
172
173            if ($tagname eq 'a' || $tagname eq 'A') {
174                $output .= "<$tagname";
175                my @parts;
176                my $href = delete $attr->{href};
177                if ($href) {
178                    $output .= " ";
179                    push @parts,
180                      sprintf( qq{href="$base?q=%s"},
181                        uri_escape(URI->new($href)->abs($base_url)) );
182                }
183                push @parts, map { sprintf qq{%s="%s"}, encode_entities($_), encode_entities($attr->{$_}) } keys %$attr;
184                $output .= join " ", @parts;
185                $output .= ">";
186            } elsif ($tagname =~ /form/i) {
187                $output .= "<$tagname";
188                my @parts;
189                my $action = delete $attr->{action};
190                if ($action) {
191                    $output .= " ";
192                    push @parts, sprintf(qq{action="$base?q=%s"},
193                        uri_escape(URI->new($action)->abs($base_url))
194                    );
195                }
196                push @parts, map { sprintf qq{$_="%s"}, encode_entities($attr->{$_}) } keys %$attr;
197                $output .= join " ", @parts;
198                $output .= ">";
199            } elsif ($tagname =~ /img/i) {
200                $output .= "<$tagname";
201                my @parts;
202                my $src = delete $attr->{src};
203                if ($src) {
204                    $output .= " ";
205                    push @parts, sprintf(qq{src="$base?q=%s"},
206                        uri_escape(URI->new($src)->abs($base_url))
207                    );
208                }
209                push @parts, map { sprintf qq{%s="%s"}, encode_entities($_), encode_entities($attr->{$_}) } grep !/^\/$/, keys %$attr;
210                $output .= join " ", @parts;
211                $output .= ">";
212            } else {
213                $output .= $orig;
214                return;
215            }
216        }, "tagname, attr, text" ],
217        end_h  => [ sub { $output .= shift }, "text"],
218        text_h => [ sub { $output .= shift }, "text"],
219    );
220
221    $parser->boolean_attribute_value('__BOOLEAN__');
222    $parser->parse($html);
223    $output;
224}
225
2261;
227
228__END__
229
230=head1 NAME
231
232Moxy::Plugin::Application - web proxy mode.
233
234=head1 SYNOPSIS
235
236  - module: ControlPanel
237
238
239=head1 DESCRIPTION
240
241This is web proxy mode plugin.
242
243=head1 DISCLAIMER
244
245THIS MODULE IS EXPERIMENTAL. STILL ALPHA QUALITY.
246
247=head1 KNOWN BUGS
248
249Basic 認証かかってると、うまく見えない。
250
251=head1 AUTHOR
252
253    Tokuhiro Matsuno
254
255=head1 SEE ALSO
256
257L<Moxy>
258
Note: See TracBrowser for help on using the browser.