package Moxy; use strict; use warnings; use Class::Component 0.16; our $VERSION = '0.44'; use Carp; use Encode; use File::Spec::Functions; use FindBin; use HTML::Entities; use HTML::Parser; use HTML::TreeBuilder::XPath; use HTML::TreeBuilder; 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 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/); sub new { my ($class, $config) = @_; my $self = $class->NEXT( 'new' => { config => $config } ); $self->conf->{global}->{log}->{fh} ||= \*STDERR; $self->_init_storage; return $self; } sub assets_path { my $self = shift; return $self->{__assets_path} ||= do { $self->conf->{global}->{assets_path} || dir( $FindBin::RealBin, 'assets' )->stringify; }; } # ------------------------------------------------------------------------- sub _init_storage { my ($self, ) = @_; my $mod = $self->{config}->{global}->{storage}->{module}; $mod = $mod ? "Moxy::Storage::$mod" : 'Moxy::Storage::DBM_File'; $mod->use or die $@; $self->{storage} = $mod->new($self, $self->conf->{global}->{storage} || {}); } sub storage { shift->{storage} } # ------------------------------------------------------------------------- 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 { 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) ) { $node->attr( $attr_name => sprintf( qq{%s%s%s}, $base, ($base =~ m{/$} ? '' : '/'), uri_escape( URI->new($attr)->abs($base_url) ) ) ); } } }; # replace. $replace->( 'img' => 'src' ); $replace->( 'script' => 'src' ); $replace->( 'form' => 'action' ); $replace->( 'a' => 'href' ); $replace->( 'link' => 'href' ); # dump. my $result = $tree->as_HTML(q{<>"&'}); $tree = $tree->delete; # cleanup :-) HTML::TreeBuilder needs this. # return result. return $result; } sub render_start_page { my $base = shift; return sprintf(<<"..."); ... } sub handle_request { my ($self, $c) = @_; my $session_id = join ',', $c->req->headers->authorization_basic; $self->log(debug => "Authorization header: $session_id"); if ($session_id) { $self->_make_response( c => $c, user_id => $session_id, ); } else { $c->res->status(401); $c->res->headers->www_authenticate(qq{Basic realm="Moxy needs basic auth.Only for identification.Password is dummy."}); $c->res->body('authentication required'); } } sub _make_response { my $self = shift; my %args = validate( @_ => +{ c => { isa => 'HTTP::Engine::Compat::Context', }, user_id => { type => SCALAR }, } ); my $c = $args{c}; my $base = $c->req->uri->clone; $base->path(''); $base->query_form({}); (my $url = $c->req->uri->path_query) =~ s!^/!!; $url = uf_uristr(uri_unescape $url); if ($url) { # do proxy my $res = $self->_do_request( url => $url, request => $c->req->as_http_request, user_id => $args{user_id}, ); $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 ($uri->port != 80 && $location->port != $uri->port) { $location->port($uri->port); } $res->header( 'Location' => $base . '/' . uri_escape( $location ) ); $self->log(debug => "redirect to " . $res->header('Location')); } else { my $content_type = $res->header('Content-Type'); $self->log("Content-Type: $content_type"); if ($content_type =~ /html/i) { $res->content( encode($res->charset, rewrite($base, decode($res->charset, $res->content), $url)) ); } use bytes; $res->header('Content-Length' => bytes::length($res->content)); } $c->res->set_http_response($res); } else { # please input url. $c->res->status(200); $c->res->content_type('text/html; charset=utf8'); $c->res->body( render_start_page($base) ); } } sub _do_request { my $self = shift; my %args = validate( @_ => +{ url => qr{^https?://}, request => { isa => 'HTTP::Request' }, user_id => { type => SCALAR }, } ); # make request my $req = $args{request}->clone; $req->uri($args{url}); $req->header('Host' => URI->new($args{url})->host); $self->run_hook( 'request_filter_process_agent', { request => $req, # HTTP::Request object user => $args{user_id}, } ); my $mobile_attribute = HTTP::MobileAttribute->new($req->headers); my $carrier = $mobile_attribute->carrier; 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, user => $args{user_id}, } ); 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, ); my $response = $ua->request($req); for my $hook ( 'response_filter', "response_filter_$carrier", 'render_location_bar' ) { $self->run_hook( $hook, { response => $response, # HTTP::Response object mobile_attribute => $mobile_attribute, user => $args{user_id}, } ); } $response; } 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