root/lang/perl/Moxy/trunk/lib/Moxy.pm @ 9979

Revision 9979, 9.8 kB (checked in by tokuhirom, 6 years ago)

lang/perl/Moxy: Checking in changes prior to tagging of version 0.30. Changelog diff is:

=== Changes
==================================================================
--- Changes (revision 11532)
+++ Changes (local)
@@ -1,5 +1,23 @@

Revision history for Moxy


+0.30
+
+ - MAJOR VERSION UP RELEASE!!
+ - THIS RELEASE HAVE MANY INCOMPATIBLE CHANGES
+
+ - based on Class::Component(tokuhirom)
+ - Plugin::Filter::* renamed to Plugin::*(tokuhirom)
+ - Plugin::Server::* renamed to Server::*(tokuhirom)
+ - added many tests!(tokuhirom)
+
+ - new features!
+ -- guid=ON support(tokuhirom).
+ -- focus to location bar(requested by nekokak++)
+ -- controll panel is moved to 右上.(precuredaisuki++)
+
+ - bug fixed
+ -- DisableTableTag?: bug fixed...
+

0.25


  • (SECURITY FIX) do not allow the file schema.(reported by yappo++)

Unknown target: CHANGES.

Line 
1package Moxy;
2use strict;
3use warnings;
4use Class::Component;
5
6our $VERSION = '0.30';
7
8use Path::Class;
9use YAML;
10use Encode;
11use FindBin;
12use UNIVERSAL::require;
13use Carp;
14use 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];
39
40__PACKAGE__->load_components(qw/Plaggerize Autocall::InjectMethod Context/);
41
42sub new {
43    my ($class, $config) = @_;
44
45    my $self = $class->NEXT( 'new' => { config => $config } );
46
47    $self->_init_storage;
48
49    return $self;
50}
51
52sub run {
53    my $self = shift;
54
55    unless ($self->can('run_server')) {
56        die "Oops. please load Server Module\n";
57    }
58
59    $self->run_server();
60}
61
62sub assets_path {
63    my $self = shift;
64
65    return $self->{__assets_path} ||= do {
66        $self->conf->{global}->{assets_path}
67            || dir( $FindBin::RealBin, 'assets' )->stringify;
68    };
69}
70
71# -------------------------------------------------------------------------
72
73sub _init_storage {
74    my ($self, ) = @_;
75
76    my $mod = $self->{config}->{global}->{storage}->{module};
77       $mod = $mod ? "Moxy::Storage::$mod" : 'Moxy::Storage::DBM_File';
78    $mod->use or die $@;
79    $self->{storage} = $mod->new($self, $self->conf->{global}->{storage} || {});
80}
81
82sub storage { shift->{storage} }
83
84# -------------------------------------------------------------------------
85
86sub run_hook_and_get_response {
87    my ($self, $hook, @args) = @_;
88
89    $self->log(debug => "Run hook and get response: $hook");
90    for my $action (@{$self->class_component_hooks->{$hook}}) {
91        my $code = $action->{plugin}->can($action->{method});
92        my $response = $code->($action->{plugin}, $self, @args);
93        return $response if blessed $response && $response->isa('HTTP::Response');
94    }
95    return; # not finished yet
96}
97
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
3211;
322__END__
323
324=head1 NAME
325
326Moxy - Mobile web development proxy
327
328=head1 DESCRIPTION
329
330Moxy is a mobile web development proxy.
331
332=head1 AUTHOR
333
334    Kan Fushihara
335    Tokuhiro Matsuno
336
337=head1 THANKS TO
338
339Kazuhiro Osawa
340
341=head1 LICENSE
342
343This library is free software; you can redistribute it and/or modify
344it under the same terms as Perl itself.
345
346=head1 SEE ALSO
347
348L<http://coderepos.org/share/wiki/ssb>
Note: See TracBrowser for help on using the browser.