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

Revision 10722, 9.1 kB (checked in by tokuhirom, 5 years ago)

HTTP::Engine が結構いい感じになってきたので、本体に侵食させてもよさそう

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