package Moxy; use 5.00800; use strict; use warnings; use base qw/Class::Accessor::Fast/; use Class::Component 0.16; our $VERSION = '0.70'; use Carp; use Encode; use File::Spec::Functions; use File::Basename; use FindBin; use HTML::Entities; use HTML::Parser; use HTML::TreeBuilder::XPath; use HTML::TreeBuilder; use HTTP::Cookies; use HTTP::Session; use LWP::UserAgent; use MIME::Base64; use Moxy::Util; use Params::Validate ':all'; use Path::Class; use Scalar::Util qw/blessed/; use UNIVERSAL::require; use URI::Escape; use URI::Heuristic qw(uf_uristr); use URI; use YAML; use Time::HiRes (); use Plack::Response; use Moxy::Request; use HTTP::Message::PSGI; use File::Temp; use File::Spec; use HTTP::MobileAttribute plugins => [ qw/CarrierLetter IS/, { module => 'Display', config => { DoCoMoMap => YAML::LoadFile( catfile( 'assets', 'common', 'docomo-display-map.yaml' ) ) } }, ]; __PACKAGE__->load_components(qw/Plaggerize Autocall::InjectMethod Context/); __PACKAGE__->load_plugins(qw/ DisplayWidth ControlPanel LocationBar Pictogram Status::401 Status::500 Status::404 UserID XMLisHTML UserAgentSwitcher RefererCutter CookieCutter FlashUseImgTag DisableTableTag GPS HTTPHeader QRCode ShowHTTPHeaders /); __PACKAGE__->mk_accessors(qw/response_time/); sub new { my ($class, $config) = @_; if ( $config->{global}->{plugins} ) { $class->load_plugins(@{ $config->{global}->{plugins} }); } $config->{global}->{log}->{level} ||= 'info'; $config->{global}->{assets_path} ||= do { my $libpath = $INC{'Moxy.pm'}; $libpath =~ s!(?:blib/)?lib/+Moxy\.pm$!!; $libpath ||= './'; $libpath = File::Spec->rel2abs($libpath); File::Spec->catdir($libpath, 'assets'); }; my $self = $class->NEXT( 'new' => { config => $config } ); $self->conf->{global}->{session}->{store} ||= +{ module => 'File', config => { dir => do { my $dir = File::Temp::tempdir('moxyXXXXXX', CLEANUP => 1, DIR => File::Spec->tmpdir); $self->{__session} = $dir; "$dir", # we need stringify for file::temp } }, }; $self->conf->{global}->{log}->{fh} ||= \*STDERR; return $self; } sub assets_path { shift->conf->{global}->{assets_path} } sub res { Plack::Response->new(@_); } sub HTTP::Response::to_plack_response { my $self = shift; return res( $self->code, $self->headers, $self->content, ); } # ------------------------------------------------------------------------- sub run_hook_and_get_response { my ($self, $hook, @args) = @_; $self->log(debug => "Run hook and get response: $hook"); for my $action (@{$self->class_component_hooks->{$hook}}) { my $code = $action->{plugin}->can($action->{method}); my $response = $code->($action->{plugin}, $self, @args); return $response if blessed $response && $response->isa('HTTP::Response'); } return; # not finished yet } sub rewrite_css { my ($base, $css, $url) = @_; my $base_url = URI->new($url); $css =~ s{url\(([^\)]+)\)}{ my $x = $1; sprintf "url(%s%s%s)", $base, ($base =~ m{/$} ? '' : '/'), uri_escape( URI->new($x)->abs($base_url) ) }ge; $css; } sub rewrite_html { my ($base, $html, $url) = @_; my $base_url = URI->new($url); # parse. my $tree = HTML::TreeBuilder::XPath->new; $tree->implicit_tags(0); $tree->no_space_compacting(1); $tree->ignore_ignorable_whitespace(0); $tree->store_comments(1); $tree->ignore_unknown(0); $tree->parse($html); $tree->eof; # define replacer. my $replace = sub { my ( $tag, $attr_name ) = @_; for my $node ( $tree->findnodes("//$tag") ) { if ( my $attr = $node->attr($attr_name) ) { next if $attr =~ /^mailto:/; if ($attr =~ /^tel:([0-9-]+)$/) { my $tel = $1; $node->attr( 'onclick' => qq{prompt('tel', '$1');return false;} ); } else { # maybe /https?/ my $target_url = URI->new($attr); $target_url = $target_url->abs($base_url) if $base_url; $node->attr( $attr_name => sprintf( qq{%s%s%s}, $base, ($base =~ m{/$} ? '' : '/'), uri_escape( $target_url ) ) ); } } } }; # replace. $replace->( 'img' => 'src' ); $replace->( 'script' => 'src' ); $replace->( 'form' => 'action' ); $replace->( 'a' => 'href' ); $replace->( 'link' => 'href' ); $replace->( 'object' => 'data' ); # dump. my $result = ''; for my $elm ($tree->guts) { $result .= ref $elm ? $elm->as_HTML(q{<>"&'}, '', {}) : $elm; } $tree->delete; # cleanup :-) HTML::TreeBuilder needs this. # return result. $result = ''.$result.'' unless $result =~ /<\s*html/; return $result; } sub to_app { my ($self) = @_; sub { my $env = shift; my $req = Moxy::Request->new($env); my $res = $self->handle_request($req); $res->content_length( length($res->content) ); # adjust content-length. $res->finalize(); }; } sub handle_request { my ($self, $req) = @_; $self->log(debug => "---------------------------"); my $conf = $self->conf->{global}->{session}; my $state_type = $conf->{state}->{module} || 'BasicAuth'; my $state = sub { if ($state_type eq 'Cookie') { require HTTP::Session::State::Cookie; HTTP::Session::State::Cookie->new( $conf->{state}->{config} ); } else { require Moxy::Session::State::BasicAuth; Moxy::Session::State::BasicAuth->new( $conf->{state}->{config} || {} ); } }->(); my $store = sub { my $postfix = $conf->{store}->{module} or die "missing session store module name"; my $klass = "HTTP::Session::Store::${postfix}"; $klass->require or die $@; $klass->new( $conf->{store}->{config} ); }->(); my $auth = join(',', $req->headers->authorization_basic); if ($state->isa('Moxy::Session::State::BasicAuth') && !$auth) { $self->log(debug => 'basicauth'); return res( 401, [ WWW_Authenticate => qq{Basic realm="Moxy needs basic auth.Only for identification.Password is dummy."}, ], 'authentication required', ); } else { $self->log(debug => "session: state: $state, store: $store"); my $session = HTTP::Session->new( state => $state, store => $store, request => $req, ); $self->log(debug => "session: $session"); my $res = $self->_make_response( req => $req, session => $session, ); $session->response_filter($res); $session->finalize; return $res; } } sub _make_response { my $self = shift; my %args = validate( @_ => +{ req => { isa => 'Moxy::Request', }, session => { type => OBJECT }, } ); my $req = $args{req}; my $base = $req->uri->clone; $base->path(''); $base->query_form({}); (my $url = $req->uri->path_query) =~ s!^/!!; $url = uf_uristr(uri_unescape($url)); if ($url) { # do proxy my $res = $self->_do_request( url => $url, request => $req->as_http_request, session => $args{session}, ); $self->log(debug => '-- response status: ' . $res->code); if ($res->code == 302) { # rewrite redirect my $location = URI->new($res->header('Location')); $self->log(debug => "redirect to $location"); my $uri = URI->new($url); if (not defined $location->scheme) { # path only redirect is invalid! # e.g. Location: /foo/ $self->log(error => "----------------------------"); $self->log(error => "INVALID REDIRECT!! $location"); $self->log(error => "----------------------------"); $location = URI->new( $location->as_string, $uri->scheme ); $location->scheme($uri->scheme); $location->host($uri->host); $location->port($uri->port); $self->log(error => "FIXED TO: $location"); $self->log(error => "----------------------------"); } else { if ($uri->port != 80 && $location->port != $uri->port) { $location->port($uri->port); } } my $redirect = $base . '/' . uri_escape($location); $self->log(debug => "redirect to $redirect"); return res( 302, [ Location => $redirect, ], ); } else { my $content_type = $res->header('Content-Type'); $self->log(debug => "Content-Type: $content_type"); if ($content_type =~ /html/i) { $res->content( encode($res->charset, rewrite_html($base, decode($res->charset, $res->content), $url), Encode::FB_HTMLCREF) ); } elsif ($content_type =~ m{text/css}) { $res->content( encode($res->charset, rewrite_css($base, decode($res->charset, $res->content), $url), Encode::FB_HTMLCREF) ); } return $res->to_plack_response(); } } else { # please input url. my $response = HTTP::Response->new( 200 => 'ok', HTTP::Headers->new( 'content-type' => 'text/html;charset=utf-8', ), q{ moxy start page

moxy start page

please input url to location bar

}, ); $response->request($req->as_http_request); $self->_post_process( response => $response, mobile_attribute => HTTP::MobileAttribute->new('KDDI-KC26 UP.Browser/6.2.0.7.3.129 (GUI) MMP/2.0'), session => $args{session}, ); $response->content( encode($response->charset, rewrite_html($base, decode($response->charset, $response->content), ''), Encode::FB_HTMLCREF) ); return $response->to_plack_response(); } } sub _do_request { my $self = shift; my %args = validate( @_ => +{ url => qr{^https?://}, request => { isa => 'HTTP::Request' }, session => { type => OBJECT }, } ); # make request my $req = $args{request}->clone; $req->uri($args{url}); $req->header('Host' => do { my $u = URI->new($args{url}); my $header = $u->host; $header .= ':' . $u->port if $u->port != 80; $header; } ); $self->run_hook( 'request_filter_process_agent', { request => $req, # HTTP::Request object session => $args{session}, } ); my $mobile_attribute = HTTP::MobileAttribute->new($req->headers); my $carrier = $mobile_attribute->carrier; my $cookie_jar = $args{session}->get('cookies') || HTTP::Cookies->new(); # load cookies if ($mobile_attribute->is_docomo) { undef $cookie_jar; # docomo phone doesn't support cookies } for my $hook ('url_handle', "url_handle_$carrier") { my $response = $self->run_hook_and_get_response( $hook, +{ request => $req, # HTTP::Request object mobile_attribute => $mobile_attribute, session => $args{session}, } ); if ($response) { return $response; # finished } } # do request my $ua = LWP::UserAgent->new( timeout => $self->conf->{global}->{timeout} || 10, max_redirects => 0, protocols_allowed => [qw/http https/], parse_head => 0, cookie_jar => $cookie_jar, ); $ua->add_handler( request_prepare => sub { my ($req, $ua, $h) = @_; for my $hook ('request_filter', "request_filter_$carrier") { my $response = $self->run_hook_and_get_response( $hook, +{ request => $req, # HTTP::Request object mobile_attribute => $mobile_attribute, session => $args{session}, } ); if ($response) { return $response; # finished } } $req->remove_header('Accept-Encoding'); # I HATE gziped CONTENT $req->remove_header('Cookie'); # remove Cookie from the client $req; }); $ua->add_handler( response_done => sub { my ($response, $ua, $h) = @_; my $location = $response->header('Location'); if ($location) { my $content = $response->content || ''; $self->log(info => "redirect to '$location', $content"); } $response; }); $self->log(debug => "request to @{[ $req->uri ]}"); my $t1 = Time::HiRes::gettimeofday(); my $response = $ua->request($req); my $t2 = Time::HiRes::gettimeofday(); $self->response_time( $t2-$t1 ); $self->log(debug => "and, request was @{[ $response->request->uri ]}"); $args{session}->set('cookies' => $cookie_jar); # save cookies $self->_post_process( response => $response, mobile_attribute => $mobile_attribute, session => $args{session}, ); $self->response_time( -1 ); # clear response time $response; } sub _post_process { my $self = shift; my %args = validate( @_ => { response => 1, mobile_attribute => 1, session => 1, }, ); my $carrier = $args{mobile_attribute}->carrier; for my $hook ( 'status_handler', 'security_filter', 'response_filter', "response_filter_$carrier", 'render_location_bar' ) { $self->run_hook( $hook, \%args ); } } 1; __END__ =for stopwords nyarla-net =head1 NAME Moxy - Mobile web development proxy =head1 DESCRIPTION Moxy is a mobile web development proxy. =head1 AUTHOR Kan Fushihara Tokuhiro Matsuno =head1 THANKS TO Kazuhiro Osawa nyarla-net =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L