File Coverage

blib/lib/Kossy.pm

Criterion	Covered	Total	%
statement	162	190	85.2
branch	35	56	62.5
condition	13	22	59.0
subroutine	32	35	91.4
pod	6	7	85.7
total	248	310	80.0

package Kossy;

use strict;
use warnings;
use 5.008004;
use utf8;
use Carp qw//;
use Cwd qw//;
use File::Basename qw//;
use Text::Xslate;
use HTML::FillInForm::Lite qw//;
use JSON qw//;
use Scalar::Util qw//;
use Try::Tiny;
use Encode;
use Router::Boom;
use Class::Accessor::Lite (
    new => 0,
    rw => [qw/root_dir/]
);
use base qw/Exporter/;
use Kossy::Exception;
use Kossy::Connection;
use Kossy::Request;
use Kossy::Response;
use HTTP::Headers::Fast;

our $VERSION = '0.60';
our @EXPORT = qw/new root_dir psgi build_app _router _connect get post router filter _wrap_filter/;

our $XSLATE_CACHE = 1;
our $XSLATE_CACHE_DIR;
our $SECURITY_HEADER = 1;
our $JSON_SERIALIZER;

# cache underscore translation
HTTP::Headers::Fast::_standardize_field_name('X-Frame-Options');

sub new {
    my $class = shift;
    my %args;
    if ( @_ < 2 ) {
        my $root_dir = shift;
        my @caller = caller;
        $root_dir ||= File::Basename::dirname( Cwd::realpath($caller[1]) );
        $args{root_dir} = $root_dir;
    }
    else {
        %args = @_;
    }

    bless \%args, $class;
}

sub psgi {
    my $self = shift;
    if ( ! ref $self ) {
        my %args;
        if ( @_ < 2 ) {
            my $root_dir = shift;
            my @caller = caller;
            $root_dir ||= File::Basename::dirname( Cwd::realpath($caller[1]) );
            $args{root_dir} = $root_dir;
        }
        else {
            %args = @_;
        }
        $self = $self->new(%args);
    }

    $self->build_app;
}

sub build_app {
    my $self = shift;

    #router
    my $router = Router::Boom->new;
    $router->add($_ => $self->_router->{$_} ) for keys %{$self->_router};
    my $security_header_local = $SECURITY_HEADER;
    my %match_cache;

    my $tx = __PACKAGE__->_build_text_xslate(
        root_dir  => $self->root_dir,
        cache     => $XSLATE_CACHE,
        cache_dir => $XSLATE_CACHE_DIR,
    );

    my $json_serializer = __PACKAGE__->_build_json_serializer();

    sub {
        my $env = shift;
        $Kossy::Response::SECURITY_HEADER = $security_header_local;
        try {
            my $header = bless {
                'content-type' => 'text/html; charset=UTF-8',
                $security_header_local ? ('x-frame-options' => 'DENY') : (),
            }, 'HTTP::Headers::Fast';
            my $c = Kossy::Connection->new({
                tx => $tx,
                req => Kossy::Request->new($env),
                res => Kossy::Response->new(200, $header),
                stash => {},
                json_serializer => $json_serializer,
            });
            my $method = uc($env->{REQUEST_METHOD});
            my $cache_key = $method . '-' . $env->{PATH_INFO};
            my ($match,$args) = try {
                if ( exists $match_cache{$cache_key} ) {
                    return @{$match_cache{$cache_key}};
                }
                my $path_info = Encode::decode_utf8( $env->{PATH_INFO},  Encode::FB_CROAK | Encode::LEAVE_SRC );
                my @match = $router->match($path_info);
                if ( !@match ) {
                    $c->halt(404);
                }

                if ( !exists $match[0]->{$method}) {
                    $c->halt(405);
                }
                $match_cache{$cache_key} = [$match[0]->{$method},$match[1]]
                    if ! scalar keys %{$match[1]};
                return ($match[0]->{$method},$match[1]);
            } catch {
                if ( ref $_ && ref $_ eq 'Kossy::Exception' ) {
                    die $_; #rethrow
                }
                $c->halt(400,'unexpected character in request');
            };

            my $code = $match->{__action__};
            my $filters = $match->{__filter__} || [];
            if ( $] == 5.020000 || $] == 5.020100 ) {
                # workaround for 5.20.0 or 5.20.1 https://github.com/kazeburo/Kossy/pull/10
                my %args = map { $_ => Encode::decode_utf8($args->{$_}) } keys %$args;
                $c->args(\%args);
            } else {
                $c->args({%$args});
            }
            my $app = sub {
                my ($self, $c) = @_;
                my $response;
                my $res = $code->($self, $c);
                Carp::croak "Undefined Response" if ! defined $res;
                my $res_t = ref($res) || '';
                if ( $res_t eq 'Kossy::Response' ) {
                    $response = $res;
                }
                elsif ( $res_t eq 'Plack::Response' ) {
                    $response = bless $res, 'Kossy::Response';
                }
                elsif ( $res_t eq 'ARRAY' ) {
                    $response = Kossy::Response->new(@$res);
                }
                elsif ( !$res_t ) {
                    $c->res->body($res);
                    $response = $c->res;
                }
                else {
                    Carp::croak sprintf "Unknown Response: %s", $res_t;
                }
                $response;
            };

            for my $filter ( reverse @$filters ) {
                $app = $self->_wrap_filter($filter,$app);
            }
            # do all
            local $Kossy::Response::DIRECT;
            $app->($self, $c)->finalize;
        } catch {
            if ( ref $_ && ref $_ eq 'Kossy::Exception' ) {
                return $_->response;
            }
            die $_;
        };
    };
}

sub _build_text_xslate {
    my ($class, %args) = @_;
    my ($root_dir, $cache, $cache_dir) = @args{qw/root_dir cache cache_dir/};

    my $fif = HTML::FillInForm::Lite->new();
    my $tx = Text::Xslate->new(
        path => [ $root_dir . '/views' ],
        input_layer => ':utf8',
        module => ['Text::Xslate::Bridge::TT2Like','Number::Format' => [':subs']],
        function => {
            fillinform => sub {
                my $q = shift;
                return sub {
                    my ($html) = @_;
                    return Text::Xslate::mark_raw( $fif->fill( \$html, $q ) );
                }
            }
        },
        cache => $cache,
        defined $cache_dir ? ( cache_dir => $cache_dir ) : (),
    );
    return $tx
}

sub _build_json_serializer {
    my $class = shift;

    if (defined $JSON_SERIALIZER) {
        if (Scalar::Util::blessed($JSON_SERIALIZER) && $JSON_SERIALIZER->can('encode')) {
            return $JSON_SERIALIZER
        }
        else {
            Carp::croak '$Kossy::JSON_SERIALIZER must have `encode` method';
        }
    }

    # default case
    return JSON->new()->allow_blessed(1)->convert_blessed(1)->ascii(1);
}


my $_ROUTER={};
sub _router {
    my $klass = shift;
    my $class = ref $klass ? ref $klass : $klass;
    if ( !$_ROUTER->{$class} ) {
        $_ROUTER->{$class} = {};
    }
    $_ROUTER->{$class};
}

sub _connect {
    my $class = shift;
    my ( $methods, $pattern, $filter, $code ) = @_;
    $methods = ref($methods) ? $methods : [$methods];
    if (!$code) {
        $code = $filter;
        $filter = [];
    }
    for my $method ( @$methods ) {
        $class->_router->{$pattern}->{$method} = {
            __action__ => $code,
            __filter__ => $filter
        };
    }
}

sub get {
    my $class = caller;
    $class->_connect( ['GET','HEAD'], @_  );
}

sub post {
    my $class = caller;
    $class->_connect( ['POST'], @_  );
}

sub router {
    my $class = caller;
    $class->_connect( @_  );
}

my $_FILTER={};
sub filter {
    my $class = caller;
    if ( !$_FILTER->{$class} ) {
        $_FILTER->{$class} = {};
    }
    if ( @_ ) {
        $_FILTER->{$class}->{$_[0]} = $_[1];
    }
    $_FILTER->{$class};
}

sub _wrap_filter {
    my $klass = shift;
    my $class = ref $klass ? ref $klass : $klass;
    if ( !$_FILTER->{$class} ) {
        $_FILTER->{$class} = {};
    }
    my ($filter,$app) = @_;
    my $filter_subref = $_FILTER->{$class}->{$filter};
    Carp::croak sprintf("Filter:%s is not exists", $filter) unless $filter_subref;
    return $filter_subref->($app);
}

1;

__END__