Catalyst::Plugin::MobileUIDも追加

先日のHTTP::MobileUIDをCatalystから扱えるようにしたプラグインです。

package Catalyst::Plugin::MobileUID;

use strict;
use warnings;

use HTML::TokeParser::Simple;
use MIME::Types;
use NEXT;
use URI;
use URI::Find;
use URI::QueryParam;
use Catalyst::Request;
use HTTP::MobileUID;

our $VERSION = '0.01';

{
    package Catalyst::Request;
    sub mobile_uid {
        my $req = shift;
        return $req->{mobile_uid} = shift if @_;
        return $req->{mobile_uid} ||= HTTP::MobileUID->new($req->mobile_agent);
    }
}

# Catalyst::Plugin::MobileAgentに依存します。

sub setup {
    my $c = shift;
    $c->NEXT::setup(@_);
    
    my $config = $c->config->{mobile_uid} ||= {};
    unless ( exists $config->{auto} ) {
        $config->{auto} = 1;
    }
}

sub prepare_headers {
    my $c = shift;
    $c->NEXT::prepare_headers(@_);
    if ($c->req->mobile_agent->is_docomo) {
        $c->req->header('X-DoCoMo-UID' => $c->req->query_parameters->{uid})
            unless $c->req->header('X-DoCoMo-UID');
    }
}

sub _uid_rewriting_html_tag_map {
    return {
        a      => "href",
        form   => "action",
        link   => "href",
        img    => "src",
        script => "src",
    };
}

sub finalize {
    my $c = shift;
    
    return $c->NEXT::finalize(@_)
        unless $c->config->{mobile_uid}->{auto};
    
    return $c->NEXT::finalize(@_)
        if $c->req->mobile_agent->is_ezweb;
    
    my %param = ( uid => 'NULLGWDOCOMO' ); # DoCoMoの場合
    if ( $c->req->mobile_agent->is_vodafone ) {
        %param = (
            uid => 1,
            sid => $c->stash->{softbank_sid},
            %{ $c->stash->{softbank_query} || {} }
        );
    }
    
    # redirect
    if( ($c->response->status || 0) =~ /^\s*3\d\d\s*$/ ) {
        if ( my $location = $c->response->location ) {
            $c->response->location( $c->uri_with_uid($location,\%param) )
                if $c->_uid_should_rewrite_uri($location);
        }
    }
    
    # html
    if (
        ($c->response->content_type || '') =~ /html/ # XML too?
            or
        (!$c->response->content_type and $c->response->body =~ /^\s*<[?!]?\s*\w+/ ), # if it looks like html
    ) {
        $c->rewrite_html_with_uid(\%param);
    }
    
    return $c->NEXT::finalize(@_);
}

sub rewrite_html_with_uid {
    my ( $c,$param ) = @_;

    my $p = HTML::TokeParser::Simple->new( string => ($c->response->body || return) );

    $c->log->debug("Rewriting HTML body with the token parser")
        if $c->debug;

    my $tag_map = $c->_uid_rewriting_html_tag_map;

    my $body = '';
    while ( my $token = $p->get_token ) {
        if ( my $tag = $token->get_tag ) {
            # rewrite tags according to the map
            if ( my $attr_name = $tag_map->{$tag} ) {
                if ( defined(my $attr_value = $token->get_attr($attr_name) ) ) {
                    $attr_value = $c->uri_with_uid($attr_value,$param)
                        if $c->_uid_should_rewrite_uri($attr_value);
                    
                    $token->set_attr( $attr_name, $attr_value );
                }
            }
        }

        $body .= $token->as_is;
    }

    $c->response->body($body);
}

sub uri_with_uid {
    my ($c,$uri_text,$param) = @_;
    my $uri_obj = eval { URI->new($uri_text) } || return $uri_text;
    $uri_obj->query_param( $_ => $param->{$_} ) for keys %$param;
    return $uri_obj;
}

sub _uid_should_rewrite_uri {
    my ($c,$uri_text) = @_;
    
    my $uri_obj = eval { URI->new($uri_text) } || return;
    
    my $rel = $uri_obj->abs( $c->request->base );
    
    return unless index( $rel, $c->request->base ) == 0;
    
    return unless $c->_uid_should_rewrite_uri_mime_type($rel);
    
    return not defined $uri_obj->query_param('uid');
}

sub _uid_should_rewrite_uri_mime_type {
    my ( $c, $uri ) = @_;
    
    # ignore media type such as gif, pdf and etc
    if ( $uri->path =~ m#\.(\w+)(?:\?|$)# ) {
        my $mt = new MIME::Types->mimeTypeOf($1);
        
        if ( ref $mt ) {
            return if $mt->isBinary;
        }
    }
    
    return 1;
}

1;

ただ単にHTTP::MobileUIDを返すだけではなく、URLに自動的に公式ユーザIDを取得するためのクエリを突っ込んでくれたりします。

DoCoMoの場合はuid=NULLGWDOCOMO、Softbankの場合はまー色々。$c->stash->{softbank_query}にハッシュリファを突っ込めばそれらを突っ込んでくれますのでお好きなように。最初は設定ファイルで定義できるようにしようかとも考えたんだけどやめた、管理の仕方が人それぞれだろうしstashから取ってきたほうが柔軟で便利だと思ったので。

AUの場合は何もつけない。

で、クエリの自動挿入がうぜぇ！って人もいるかと思ったんでそれは設定ファイルに

 mobile_uid:
   auto: 0

と書けば自動挿入しなくなりまする。デフォルトではON。

ちなみに当然のことながらこのモジュールは公式サイトでしか（ｒｙ