Kossy/lib/Kossy.pm
package Kossy;
use strict;
use warnings;
use utf8;
use Carp qw//;
use Scalar::Util qw//;
use Router::Simple;
use Cwd qw//;
use File::Basename qw//;
use Text::Xslate;
use HTML::FillInForm::Lite qw//;
use Try::Tiny;
use Encode;
use Class::Accessor::Lite (
new => 0,
rw => [qw/root_dir/]
);
use base qw/Exporter/;
our $VERSION = '0.13';
our @EXPORT = qw/new root_dir psgi build_app _router _connect get post router filter _wrap_filter/;
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 $root_dir = shift;
my @caller = caller;
$root_dir ||= File::Basename::dirname( Cwd::realpath($caller[1]) );
$self = $self->new($root_dir);
}
$self->build_app;
}
sub build_app {
my $self = shift;
#router
my $router = Router::Simple->new;
$router->connect(@{$_}) for @{$self->_router};
#xslate
my $fif = HTML::FillInForm::Lite->new();
my $tx = Text::Xslate->new(
path => [ $self->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 ) );
}
}
},
);
sub {
my $env = shift;
my $c = Kossy::Connection->new({
tx => $tx,
req => Kossy::Request->new($env),
res => Kossy::Response->new(200),
stash => {},
});
$c->res->content_type('text/html; charset=UTF-8');
my $match = try {
local $env->{PATH_INFO} = Encode::decode_utf8( $env->{PATH_INFO}, Encode::FB_CROAK | Encode::LEAVE_SRC );
$router->match($env)
}
catch {
$c->halt(400,'unexpected character in request');
};
if ( $match ) {
my $code = delete $match->{action};
my $filters = delete $match->{filter};
$c->args($match);
my $app = sub {
my ($self, $c) = @_;
my $response;
my $res = $code->($self, $c);
Carp::croak "Undefined Response" if !$res;
my $res_t = ref($res) || '';
if ( Scalar::Util::blessed $res && $res->isa('Kossy::Response') ) {
$response = $res;;
}
elsif ( Scalar::Util::blessed $res && $res->isa('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);
}
return try {
$app->($self, $c)->finalize;
} catch {
if ( ref $_ && ref $_ eq 'Kossy::Exception' ) {
return $_->response;
}
die $_;
};
}
return Kossy::Exception->new(404)->response;
};
}
my $_ROUTER={};
sub _router {
my $klass = shift;
my $class = ref $klass ? ref $klass : $klass;
if ( !$_ROUTER->{$class} ) {
$_ROUTER->{$class} = [];
}
if ( @_ ) {
push @{ $_ROUTER->{$class} }, [@_];
}
$_ROUTER->{$class};
}
sub _connect {
my $class = shift;
my ( $methods, $pattern, $filter, $code ) = @_;
$methods = ref($methods) ? $methods : [$methods];
if (!$code) {
$code = $filter;
$filter = [];
}
$class->_router(
$pattern,
{ action => $code, filter => $filter },
{ method => [ map { uc $_ } @$methods ] }
);
}
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);
}
package Kossy::Exception;
use strict;
use warnings;
use HTTP::Status;
use Text::Xslate qw/html_escape/;
sub new {
my $class = shift;
my $code = shift;
my %args = (
code => $code,
);
if ( @_ == 1 ) {
$args{message} = shift;
}
elsif ( @_ % 2 == 0) {
%args = (
%args,
@_
);
}
bless \%args, $class;
}
sub response {
my $self = shift;
my $code = $self->{code} || 500;
my $message = $self->{message};
$message ||= HTTP::Status::status_message($code);
my @headers = (
'Content-Type' => q!text/html; charset=UTF-8!,
);
if ($code =~ /^3/ && (my $loc = eval { $self->{location} })) {
push(@headers, Location => $loc);
}
return Kossy::Response->new($code, \@headers, [$self->html($code,$message)])->finalize;
}
sub html {
my $self = shift;
my ($code,$message) = @_;
$code = html_escape($code);
$message = html_escape($message);
return <<EOF;
<!doctype html>
<html>
<head>
<meta charset=utf-8 />
<style type="text/css">
.message {
font-size: 200%;
margin: 20px 20px;
color: #666;
}
.message strong {
font-size: 250%;
font-weight: bold;
color: #333;
}
</style>
</head>
<body>
<p class="message">
<strong>$code</strong> $message
</p>
</div>
</body>
</html>
EOF
}
package Kossy::Connection;
use strict;
use warnings;
use Class::Accessor::Lite (
new => 1,
rw => [qw/req res stash args tx debug/]
);
use JSON qw//;
my $_JSON = JSON->new()->ascii(1);
my %_ESCAPE = (
'+' => '\\u002b', # do not eval as UTF-7
'<' => '\\u003c', # do not eval as HTML
'>' => '\\u003e', # ditto.
);
*request = \&req;
*response = \&res;
sub halt {
my $self = shift;
die Kossy::Exception->new(@_);
}
sub redirect {
my $self = shift;
$self->res->redirect(@_);
$self->res;
}
sub render {
my $self = shift;
my $file = shift;
my %args = ( @_ && ref $_[0] ) ? %{$_[0]} : @_;
my %vars = (
c => $self,
stash => $self->stash,
%args,
);
my $body = $self->tx->render($file, \%vars);
$self->res->status( 200 );
$self->res->content_type('text/html; charset=UTF-8');
$self->res->body( $body );
$self->res;
}
sub render_json {
my $self = shift;
my $obj = shift;
# defense from JSON hijacking
# Copy from Amon2::Plugin::Web::JSON
if ( !$self->req->header('X-Requested-With') &&
($self->req->user_agent||'') =~ /android/i &&
defined $self->req->header('Cookie') &&
($self->req->method||'GET') eq 'GET'
) {
$self->halt(403,"Your request is maybe JSON hijacking.\nIf you are not a attacker, please add 'X-Requested-With' header to each request.");
}
# for IE7 JSON venularity.
# see http://www.atmarkit.co.jp/fcoding/articles/webapp/05/webapp05a.html
# Copy from Amon2::Plugin::Web::JSON
my $body = $_JSON->encode($obj);
$body =~ s!([+<>])!$_ESCAPE{$1}!g;
if ( ( $self->req->user_agent || '' ) =~ m/Safari/ ) {
$body = "\xEF\xBB\xBF" . $body;
}
$self->res->status( 200 );
$self->res->content_type('application/json; charset=UTF-8');
$self->res->header( 'X-Content-Type-Options' => 'nosniff' ); # defense from XSS
$self->res->body( $body );
$self->res;
}
package Kossy::Request;
use strict;
use warnings;
use parent qw/Plack::Request/;
use Hash::MultiValue;
use Encode;
use Kossy::Validator;
sub body_parameters {
my ($self) = @_;
$self->{'kossy.body_parameters'} ||= $self->_decode_parameters($self->SUPER::body_parameters());
}
sub query_parameters {
my ($self) = @_;
$self->{'kossy.query_parameters'} ||= $self->_decode_parameters($self->SUPER::query_parameters());
}
sub _decode_parameters {
my ($self, $stuff) = @_;
my @flatten = $stuff->flatten();
my @decoded;
while ( my ($k, $v) = splice @flatten, 0, 2 ) {
push @decoded, Encode::decode_utf8($k), Encode::decode_utf8($v);
}
return Hash::MultiValue->new(@decoded);
}
sub parameters {
my $self = shift;
$self->env->{'kossy.request.merged'} ||= do {
my $query = $self->query_parameters;
my $body = $self->body_parameters;
Hash::MultiValue->new( $query->flatten, $body->flatten );
};
}
sub body_parameters_raw {
shift->SUPER::body_parameters();
}
sub query_parameters_raw {
shift->SUPER::query_parameters();
}
sub parameters_raw {
my $self = shift;
$self->env->{'plack.request.merged'} ||= do {
my $query = $self->SUPER::query_parameters();
my $body = $self->SUPER::body_parameters();
Hash::MultiValue->new( $query->flatten, $body->flatten );
};
}
sub param_raw {
my $self = shift;
return keys %{ $self->parameters_raw } if @_ == 0;
my $key = shift;
return $self->parameters_raw->{$key} unless wantarray;
return $self->parameters_raw->get_all($key);
}
sub uri_for {
my($self, $path, $args) = @_;
my $uri = $self->base;
my $base = $uri->path eq "/"
? ""
: $uri->path;
$uri->path( $base . $path );
$uri->query_form(@$args) if $args;
$uri;
}
sub validator {
my ($self, $rule) = @_;
Kossy::Validator->check($self,$rule);
}
1;
package Kossy::Response;
use strict;
use warnings;
use parent qw/Plack::Response/;
use Encode;
sub finalize {
my $self = shift;
$self->header('X-Frame-Options'=>'DENY');
$self->header('X-XSS-Protection'=>'1');
$self->SUPER::finalize();
}
sub _body {
my $self = shift;
my $body = $self->body;
$body = [] unless defined $body;
if (!ref $body or Scalar::Util::blessed($body) && overload::Method($body, q("")) && !$body->can('getline')) {
return [ Encode::encode_utf8($body) ] if Encode::is_utf8($body);
return [ $body ];
} else {
return $body;
}
}
1;
__END__
=head1 NAME
Kossy - Sinatra-ish Simple and Clear web application framework
=head1 SYNOPSIS
% kossy-setup MyApp
% cd MyApp
% plackup app.psgi
## lib/MyApp/Web.pm
use Kossy;
get '/' => sub {
my ( $self, $c ) = @_;
$c->render('index.tx', { greeting => "Hello!" });
};
get '/json' => sub {
my ( $self, $c ) = @_;
my $result = $c->req->validator([
'q' => {
default => 'Hello',
rule => [
[['CHOICE',qw/Hello Bye/],'Hello or Bye']
],
}
]);
$c->render_json({ greeting => $result->valid->get('q') });
};
1;
## views/index.tx
: cascade base
: around content -> {
<: $greeting :>
: }
=head1 DESCRIPTION
Kossy is Sinatra-ish Simple and Clear web application framework, which is based upon L<Plack>, L<Router::Simple>, L<Text::Xslate> and build-in Form-Validator. That's suitable for small application and rapid development.
=head1 Kossy class
Kossy exports some methods to building application
=head2 CLASS METHODS for Kossy class
=over 4
=item my $kossy = Kossy->new( root_dir => $root_dir );
Create instance of the application object.
=back
=head2 OBJECT METHODS for Kossy class
=over 4
=item my $root_dir = $kossy->root_dir();
accessor to root directory of the application
=item my $app = $kossy->psgi();
return PSGI application
=back
=head2 DISPATCHER METHODS for Kossy class
=over 4
=item filter
makes application wrapper like plack::middlewares.
filter 'set_title' => sub {
my $app:CODE = shift;
sub {
my ( $self:Kossy, $c:Kossy::Connection ) = @_;
$c->stash->{site_name} = __PACKAGE__;
$app->($self,$c);
}
};
=item get path:String => [[filters] =>] CODE
=item post path:String => [[filters] =>] CODE
setup router and dispatch code
get '/' => [qw/set_title/] => sub {
my ( $self:Kossy, $c:Kossy::Connection ) = @_;
$c->render('index.tx', { greeting => "Hello!" });
};
get '/json' => sub {
my ( $self:Kossy, $c:Kossy::Connection ) = @_;
$c->render_json({ greeting => "Hello!" });
};
dispatch code shall return Kossy::Response object or PSGI response ArrayRef or String.
=item router 'HTTP_METHOD'|['METHOD'[,'METHOD']] => path:String => [[filters] =>] CODE
adds routing rule other than GET and POST
router 'PUT' => '/put' => sub {
my ( $self:Kossy, $c:Kossy::Connection ) = @_;
$c->render_json({ greeting => "Hello!" });
};
=back
=head1 Kossy::Connection class
per-request object, herds request and response
=head2 OBJECT METHODS for Kossy::Connection class
=over 4
=item req:Kossy::Request
=item res:Kossy::Response
=item stash:HashRef
=item args:HashRef
Router::Simple->match result
=item halt(status_code, message)
die and response immediately
=item redirect($uri,status_code): Kossy::Response
=item render($file,$args): Kossy::Response
calls Text::Xslate->render makes response. template files are searching in root_dir/views directory
template syntax is Text::Xslate::Syntax::Kolon, can use Kossy::Connection object and fillinform block.
## template.tx
: block form | fillinform( $c.req ) -> {
<head>
<title><: $c.stash.title :></title>
</head>
<body>
<form action="<: $c.req.uri_for('/post') :>">
<input type="text" size="10" name="title" />
<textarea name="body" rows="20" cols="90"></textarea>
</form>
</body>
: }
also can use L<Text::Xslate::Bridge::TT2Like> and L<Number::Format> methods in your template
=item render_json($args): Kossy::Response
serializes arguments with JSON and makes response
This method escapes '<', '>', and '+' characters by "\uXXXX" form. Browser don't detects the JSON as HTML. And also this module outputs "X-Content-Type-Options: nosniff" header for IEs.
render_json have a JSON hijacking detection feature same as L<Amon2::Plugin::Web::JSON>. This returns "403 Forbidden" response if following pattern request.
=over 8
=item The request have 'Cookie' header.
=item The request doesn't have 'X-Requested-With' header.
=item The request contains /android/i string in 'User-Agent' header.
=item Request method is 'GET'
=back
=back
=head1 Kossy::Request
This class is child class of Plack::Request, decode query/body parameters automatically. Return value of $req->param(), $req->body_parameters, etc. is the decoded value.
=head2 OBJECT METHODS for Kossy::Request class
=over 4
=item uri_for($path,$args):String
build absolute URI with path and $args
my $uri = $c->req->uri_for('/login',[ arg => 'Hello']);
=item validator($rule):Kossy::Validaor::Result
validate parameters using L<Kossy::Validatar>
my $result = $c->req->validator([
'q' => [['NOT_NULL','query must be defined']],
'level' => {
default => 'M',
rule => [
[['CHOICE',qw/L M Q H/],'invalid level char'],
],
},
]);
my $val = $result->valid('q');
my $val = $result->valid('level');
=item body_parameters_raw
=item query_parameters_raw
=item parameters_raw
=item param_raw
These methods are the accessor to raw values. 'raw' means the value is not decoded.
=back
=head1 Kossy::Response
This class is child class of Plack::Response
=head1 AUTHOR
Masahiro Nagano E<lt>kazeburo {at} gmail.comE<gt>
=head1 SEE ALSO
Kossy is small waf, that has only 400 lines code. so easy to reading framework code and customize it. Sinatra-ish router, build-in templating, validators and zero-configuration features are suitable for small application and rapid development.
L<Amon2::Lite>
L<Mojolicious::Lite>
L<Dancer>
L<Kossy::Validator>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut