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

Revision 10723, 8.6 kB (checked in by tokuhirom, 7 years ago)

HTTP::Engine の context を内部までくいこませて簡素化。でもここまでしか侵入させないよ。

RevLine 
[2891]1package Moxy;
2use strict;
3use warnings;
[10675]4use Class::Component 0.16;
[2891]5
[10042]6our $VERSION = '0.32';
[2891]7
[10672]8use Carp;
[2891]9use Encode;
[10672]10use File::Spec::Functions;
[2891]11use FindBin;
[9968]12use HTML::Entities;
[10672]13use HTML::Parser;
14use HTML::TreeBuilder::XPath;
15use HTML::TreeBuilder;
[9968]16use LWP::UserAgent;
17use MIME::Base64;
[10672]18use Moxy::Util;
[9968]19use Params::Validate ':all';
[10672]20use Path::Class;
21use Scalar::Util qw/blessed/;
22use UNIVERSAL::require;
23use URI::Escape;
[9968]24use URI::Heuristic qw(uf_uristr);
[10672]25use URI;
[9968]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];
[2891]38
[9968]39__PACKAGE__->load_components(qw/Plaggerize Autocall::InjectMethod Context/);
40
[10667]41__PACKAGE__->load_plugins(qw/DisplayWidth ControlPanel LocationBar Pictogram/);
42
[2891]43sub new {
44    my ($class, $config) = @_;
45
[9968]46    my $self = $class->NEXT( 'new' => { config => $config } );
[2891]47
[10707]48    $self->conf->{global}->{log}->{fh} ||= \*STDERR;
49
[2891]50    $self->_init_storage;
51
52    return $self;
53}
54
55sub assets_path {
56    my $self = shift;
57
58    return $self->{__assets_path} ||= do {
[9968]59        $self->conf->{global}->{assets_path}
[2891]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 $@;
[9968]72    $self->{storage} = $mod->new($self, $self->conf->{global}->{storage} || {});
[2891]73}
74
75sub storage { shift->{storage} }
76
77# -------------------------------------------------------------------------
78
[9968]79sub run_hook_and_get_response {
80    my ($self, $hook, @args) = @_;
[3025]81
[9968]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');
[3025]87    }
[9968]88    return; # not finished yet
[3025]89}
90
[9968]91sub rewrite {
92    my ($base, $html, $url) = @_;
[2891]93
[9968]94    my $base_url = URI->new($url);
[2891]95
[9999]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(
[10623]113                    $attr_name => sprintf( qq{%s%s%s},
[10047]114                        $base,
[10623]115                        ($base =~ m{/$} ? '' : '/'),
116                        uri_escape( URI->new($attr)->abs($base_url) ) )
[9999]117                );
[9968]118            }
[9999]119        }
120    };
[2891]121
[9999]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;
[2891]135}
136
[10707]137sub render_start_page {
[10723]138    my $base = shift;
[2891]139
[10012]140    return sprintf(<<"...");
[10046]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">
[9968]147        window.onload = function () {
148            document.getElementById('moxy_url').focus();
149        };
150    </script>
[10046]151</head>
152<body>
[10623]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" />
[9968]155        <input type="submit" value="go" />
156    </form>
[10046]157</body>
158</html>
[9968]159...
160}
[2891]161
[9968]162sub handle_request {
[10722]163    my ($self, $c) = @_;
[2891]164
[10722]165    my $session_id = join ',', $c->req->headers->authorization_basic;
166    $self->log(debug => "Authorization header: $session_id");
167    if ($session_id) {
[10723]168        $self->_make_response(
169            c => $c,
[10722]170            user_id  => $session_id,
[9968]171        );
172    } else {
[10722]173        $c->res->status(401);
174        $c->res->headers->www_authenticate(qq{Basic realm="Moxy needs basic auth.Only for identification.Password is dummy."});
175        $c->res->body('authentication required');
[2891]176    }
177}
178
[9968]179sub _make_response {
180    my $self = shift;
181    my %args = validate(
182        @_ => +{
[10723]183            c       => { isa  => 'HTTP::Engine::Context', },
184            user_id => { type => SCALAR },
[9968]185        }
186    );
[10723]187    my $c = $args{c};
[2891]188
[10723]189    my $base = $c->req->uri->clone;
190    $base->path('');
191    $base->query_form({});
192
193    (my $url = $c->req->uri->path_query) =~ s!^/!!;
194    $url = uf_uristr(uri_unescape $url);
195
[9968]196    if ($url) {
197        # do proxy
198        my $res = $self->_do_request(
199            url     => $url,
[10723]200            request => $c->req->as_http_request,
[9968]201            user_id => $args{user_id},
202        );
203        $self->log(debug => '-- response status: ' . $res->code);
204
205        if ($res->code == 302) {
206            # rewrite redirect
207            my $location = URI->new($res->header('Location'));
[10012]208            $self->log(debug => "redirect to $location");
[9968]209            my $uri = URI->new($url);
210            if ($uri->port != 80 && $location->port != $uri->port) {
211                $location->port($uri->port);
212            }
[10723]213            $res->header( 'Location' => $base . '/' . uri_escape( $location ) );
[10012]214            $self->log(debug => "redirect to " . $res->header('Location'));
[9968]215        } else {
216            my $content_type = $res->header('Content-Type');
[10009]217            $self->log("Content-Type: $content_type");
[9968]218            if ($content_type =~ /html/i) {
[10723]219                $res->content( encode($res->charset, rewrite($base, decode($res->charset, $res->content), $url)) );
[9968]220            }
221            use bytes;
222            $res->header('Content-Length' => bytes::length($res->content));
223        }
[10723]224        $c->res->set_http_response($res);
[9968]225    } else {
226        # please input url.
[10723]227        $c->res->status(200);
228        $c->res->content_type('text/html; charset=utf8');
229        $c->res->body( render_start_page($base) );
[2891]230    }
231}
232
[9968]233sub _do_request {
234    my $self = shift;
235    my %args = validate(
236        @_ => +{
237            url      => qr{^https?://},
238            request  => { isa  => 'HTTP::Request' },
239            user_id  => { type => SCALAR },
240        }
241    );
[4970]242
[9968]243    # make request
244    my $req = $args{request}->clone;
245    $req->uri($args{url});
246    $req->header('Host' => URI->new($args{url})->host);
247
248    $self->run_hook(
249        'request_filter_process_agent',
250        {   request => $req, # HTTP::Request object
251            user    => $args{user_id},
252        }
253    );
254    my $mobile_attribute = HTTP::MobileAttribute->new($req->headers);
255    my $carrier = $mobile_attribute->carrier;
256    for my $hook ('request_filter', "request_filter_$carrier") {
257        my $response = $self->run_hook_and_get_response(
258            $hook,
259            +{
260                request          => $req,              # HTTP::Request object
261                mobile_attribute => $mobile_attribute,
262                user             => $args{user_id},
263            }
264        );
265        if ($response) {
266            return $response; # finished
267        }
[4970]268    }
[9968]269
270    # do request
271    my $ua = LWP::UserAgent->new(
272        timeout           => $self->conf->{global}->{timeout} || 10,
273        max_redirects     => 0,
274        protocols_allowed => [qw/http https/],
[10716]275        parse_head        => 0,
[9968]276    );
277    my $response = $ua->request($req);
[10668]278    for my $hook ( 'response_filter', "response_filter_$carrier", 'render_location_bar' ) {
[9968]279        $self->run_hook(
280            $hook,
281            {
282                response         => $response,           # HTTP::Response object
283                mobile_attribute => $mobile_attribute,
284                user             => $args{user_id},
285            }
286        );
287    }
288    $response;
[4970]289}
290
[2891]291
2921;
[3964]293__END__
294
[10688]295=for stopwords nyarla-net
296
[3964]297=head1 NAME
298
299Moxy - Mobile web development proxy
300
301=head1 DESCRIPTION
302
303Moxy is a mobile web development proxy.
304
305=head1 AUTHOR
306
307    Kan Fushihara
308    Tokuhiro Matsuno
309
[9221]310=head1 THANKS TO
311
312Kazuhiro Osawa
[10672]313nyarla-net
[9221]314
[9968]315=head1 LICENSE
316
317This library is free software; you can redistribute it and/or modify
318it under the same terms as Perl itself.
319
[3964]320=head1 SEE ALSO
321
[3983]322L<http://coderepos.org/share/wiki/ssb>
Note: See TracBrowser for help on using the browser.