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

Revision 10047, 9.4 kB (checked in by tokuhirom, 5 years ago)

スラッシュついててもついてなくても大丈夫にした。

Line 
1package Moxy;
2use strict;
3use warnings;
4use Class::Component;
5
6our $VERSION = '0.32';
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 HTML::TreeBuilder;
29use Moxy::Util;
30use HTML::TreeBuilder::XPath;
31use HTTP::MobileAttribute plugins => [
32    qw/CarrierLetter IS/,
33    {
34        module => 'Display',
35        config => {
36            DoCoMoMap => YAML::LoadFile(
37                catfile( 'assets', 'common', 'docomo-display-map.yaml' )
38            )
39        }
40    },
41];
42
43__PACKAGE__->load_components(qw/Plaggerize Autocall::InjectMethod Context/);
44
45sub new {
46    my ($class, $config) = @_;
47
48    my $self = $class->NEXT( 'new' => { config => $config } );
49
50    $self->_init_storage;
51
52    return $self;
53}
54
55sub run {
56    my $self = shift;
57
58    unless ($self->can('run_server')) {
59        die "Oops. please load Server Module\n";
60    }
61
62    $self->run_server();
63}
64
65sub assets_path {
66    my $self = shift;
67
68    return $self->{__assets_path} ||= do {
69        $self->conf->{global}->{assets_path}
70            || dir( $FindBin::RealBin, 'assets' )->stringify;
71    };
72}
73
74# -------------------------------------------------------------------------
75
76sub _init_storage {
77    my ($self, ) = @_;
78
79    my $mod = $self->{config}->{global}->{storage}->{module};
80       $mod = $mod ? "Moxy::Storage::$mod" : 'Moxy::Storage::DBM_File';
81    $mod->use or die $@;
82    $self->{storage} = $mod->new($self, $self->conf->{global}->{storage} || {});
83}
84
85sub storage { shift->{storage} }
86
87# -------------------------------------------------------------------------
88
89sub run_hook_and_get_response {
90    my ($self, $hook, @args) = @_;
91
92    $self->log(debug => "Run hook and get response: $hook");
93    for my $action (@{$self->class_component_hooks->{$hook}}) {
94        my $code = $action->{plugin}->can($action->{method});
95        my $response = $code->($action->{plugin}, $self, @args);
96        return $response if blessed $response && $response->isa('HTTP::Response');
97    }
98    return; # not finished yet
99}
100
101sub rewrite {
102    my ($base, $html, $url) = @_;
103
104    my $base_url = URI->new($url);
105
106    # parse.
107    my $tree = HTML::TreeBuilder::XPath->new;
108    $tree->implicit_tags(0);
109    $tree->no_space_compacting(1);
110    $tree->ignore_ignorable_whitespace(0);
111    $tree->store_comments(1);
112    $tree->ignore_unknown(0);
113    $tree->parse($html);
114    $tree->eof;
115
116    # define replacer.
117    my $replace = sub {
118        my ( $tag, $attr_name ) = @_;
119
120        for my $node ( $tree->findnodes("//$tag") ) {
121            if ( my $attr = $node->attr($attr_name) ) {
122                $node->attr(
123                    $attr_name => sprintf( qq{%s%s%s},
124                        $base,
125                        ($base =~ m{/$} ? '' : '/'),
126                        uri_escape( URI->new($attr)->abs($base_url) ) )
127                );
128            }
129        }
130    };
131
132    # replace.
133    $replace->( 'img'    => 'src' );
134    $replace->( 'script' => 'src' );
135    $replace->( 'form'   => 'action' );
136    $replace->( 'a'      => 'href' );
137    $replace->( 'link'   => 'href' );
138
139    # dump.
140    my $result = $tree->as_HTML(q{<>"&'});
141    $tree = $tree->delete; # cleanup :-) HTML::TreeBuilder needs this.
142
143    # return result.
144    return $result;
145}
146
147sub render_control_panel {
148    my ($base, $current_url) = @_;
149
150    return sprintf(<<"...");
151<?xml version="1.0" encoding="utf-8"?>
152<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
153<html lang="ja" xml:lang="ja" xmlns="http://www.w3.org/1999/xhtml">
154<head>
155    <meta http-equiv="content-script-type" content="text/javascript" />
156    <script type="text/javascript">
157        window.onload = function () {
158            document.getElementById('moxy_url').focus();
159        };
160    </script>
161</head>
162<body>
163    <form method="get" action="$base" onsubmit="location.href=location.href+encodeURIComponent(document.getElementById('moxy_url').value);return false;">
164        <input type="text" size="40" id="moxy_url" />
165        <input type="submit" value="go" />
166    </form>
167</body>
168</html>
169...
170}
171
172sub handle_request {
173    my $self = shift;
174    my %args = validate(
175        @_,
176        +{
177            request => { isa => 'HTTP::Request' },
178        }
179    );
180
181    my $uri = URI->new($args{request}->uri);
182    $self->log(debug => "Request URI: $uri");
183
184    my $base = $uri->clone;
185    $base->path('');
186    $base->query_form({});
187
188    my $auth_header = $args{request}->header('Authorization');
189    $self->log(debug => "Authorization header: $auth_header");
190    if ($auth_header =~ /^Basic (.+)$/) {
191        my $auth = decode_base64($1);
192        $self->log(debug => "auth: $auth");
193        (my $url = $uri->path_query) =~ s!^/!!;
194        $url = uf_uristr(uri_unescape $url);
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            $self->log(debug => "redirect to $location");
239            my $uri = URI->new($url);
240            if ($uri->port != 80 && $location->port != $uri->port) {
241                $location->port($uri->port);
242            }
243            $res->header( 'Location' => $base_url . '/' . uri_escape( $location ) );
244            $self->log(debug => "redirect to " . $res->header('Location'));
245        } else {
246            my $content_type = $res->header('Content-Type');
247            $self->log("Content-Type: $content_type");
248            if ($content_type =~ /html/i) {
249                $res->content( encode($res->charset, rewrite($base_url, decode($res->charset, $res->content), $url)) );
250            }
251            use bytes;
252            $res->header('Content-Length' => bytes::length($res->content));
253        }
254        return $res;
255    } else {
256        # please input url.
257        my $res = HTTP::Response->new(200, 'about:blank');
258        $res->header('Content-Type' => 'text/html; charset=utf8');
259        my $panel = render_control_panel($base_url, '');
260        $res->content(qq{<html><head></head><body>$panel</body></html>});
261        return $res;
262    }
263}
264
265sub _do_request {
266    my $self = shift;
267    my %args = validate(
268        @_ => +{
269            url      => qr{^https?://},
270            request  => { isa  => 'HTTP::Request' },
271            user_id  => { type => SCALAR },
272        }
273    );
274
275    # make request
276    my $req = $args{request}->clone;
277    $req->uri($args{url});
278    $req->header('Host' => URI->new($args{url})->host);
279
280    $self->run_hook(
281        'request_filter_process_agent',
282        {   request => $req, # HTTP::Request object
283            user    => $args{user_id},
284        }
285    );
286    my $mobile_attribute = HTTP::MobileAttribute->new($req->headers);
287    my $carrier = $mobile_attribute->carrier;
288    for my $hook ('request_filter', "request_filter_$carrier") {
289        my $response = $self->run_hook_and_get_response(
290            $hook,
291            +{
292                request          => $req,              # HTTP::Request object
293                mobile_attribute => $mobile_attribute,
294                user             => $args{user_id},
295            }
296        );
297        if ($response) {
298            return $response; # finished
299        }
300    }
301
302    # do request
303    my $ua = LWP::UserAgent->new(
304        timeout           => $self->conf->{global}->{timeout} || 10,
305        max_redirects     => 0,
306        protocols_allowed => [qw/http https/],
307    );
308    my $response = $ua->request($req);
309    for my $hook ( 'response_filter', "response_filter_$carrier" ) {
310        $self->run_hook(
311            $hook,
312            {
313                response         => $response,           # HTTP::Response object
314                mobile_attribute => $mobile_attribute,
315                user             => $args{user_id},
316            }
317        );
318    }
319    $response;
320}
321
322
3231;
324__END__
325
326=head1 NAME
327
328Moxy - Mobile web development proxy
329
330=head1 DESCRIPTION
331
332Moxy is a mobile web development proxy.
333
334=head1 AUTHOR
335
336    Kan Fushihara
337    Tokuhiro Matsuno
338
339=head1 THANKS TO
340
341Kazuhiro Osawa
342
343=head1 LICENSE
344
345This library is free software; you can redistribute it and/or modify
346it under the same terms as Perl itself.
347
348=head1 SEE ALSO
349
350L<http://coderepos.org/share/wiki/ssb>
Note: See TracBrowser for help on using the browser.