File Coverage

blib/lib/Moxy.pm

Criterion	Covered	Total	%
statement	151	298	50.6
branch	13	50	26.0
condition	5	31	16.1
subroutine	38	52	73.0
pod	1	9	11.1
total	208	440	47.2

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__