Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
use strict;
use Test::More tests => 1;
BEGIN {
use_ok 'Udon::App';
}
use strict;
use warnings;
use FindBin qw($Bin);
use Udon::App;
use Test::More;
use HTTP::Engine::Test::Request;
plan tests => 1;
my $app = Udon::App->new( { viewdir => "$Bin/../view" } );
my $engine = $app->setup_engine( { module => 'Test' } );
my $req = HTTP::Engine::Test::Request->new( uri => 'http://udon.example.org/', method => 'GET' );
my $res = $engine->run($req);
is $res->code, '403', 'should return "Forbidden" when GET request';
use strict;
use warnings;
use FindBin qw($Bin);
use Udon::App;
use Test::Declare;
use HTTP::Engine::Test::Request;
plan tests => blocks;
describe 'GET' => run {
my $res;
my $engine;
init {
$engine =
Udon::App->new( { viewdir => "$Bin/../view" } )->setup_engine( { module => 'Test' } );
};
test 'should return "Forbidden"' => run {
$res = $engine->run(
HTTP::Engine::Test::Request->new( uri => 'http://udon.example.org/', method => 'GET' ),
);
is $res->code, '403';
};
};
use strict;
use warnings;
use FindBin qw($Bin);
use Udon::App;
use Test::Declare;
use Test::HTTP::Engine;
plan tests => blocks;
engine {
my $app = Udon::App->new( { viewdir => "$Bin/../view" } );
return sub { $app->handle_request(@_) };
};
describe 'GET' => run {
test 'should return "Forbidden"' => run {
my $res;
$res = get '/';
is $res->code, 403, 'using http method';
$res = get '/get';
is $res->code, 403, 'using path';
};
test 'should return "I\'m a teapot" with mode="prev"' => run {
my $res = get '/?mode=prev';
is $res->code, 418;
};
test 'should return "Gone" with mode="next"' => run {
my $res = get '/?mode=next';
is $res->code, 410;
};
};
package Udon::App;
use Any::Moose;
use File::Spec;
use HTTP::Engine;
use Text::MicroMason;
has 'template' => (
is => 'ro',
isa => 'Object',
default => sub { Text::MicroMason::Base->new( -SafeServerPages ) },
);
has 'cache' => (
is => 'rw',
isa => 'HashRef',
default => sub { {} },
);
has 'viewdir' => (
is => 'rw',
isa => 'Str',
default => sub { '.' },
);
no Any::Moose;
sub setup_engine {
my ( $self, $conf ) = @_;
$conf->{request_handler} = sub { $self->handle_request(@_) };
HTTP::Engine->new( interface => $conf, );
}
sub handle_request {
my ( $self, $req ) = @_;
my ( $status, $header, $body ) = $self->dispatch($req);
$header->{'Content-Type'} = 'text/html;charset=utf-8';
my $res = HTTP::Engine::Response->new;
$res->status($status);
$res->headers->header(%$header);
$res->body($body) if $body;
return $res;
}
sub dispatch {
my ( $self, $req ) = @_;
my $action = $req->uri->path;
if ( $action =~ m{/(get|head|post|put|delete|options)\z} ) {
$action = $1;
}
elsif ( $action =~ m/\.(?:pl|cgi)\z/ ) {
$action = $req->param('method') || lc( $req->method );
}
else {
$action = lc( $req->method );
}
$action = "do_$action";
return $self->can($action) ? $self->$action($req) : ( 404, {}, $self->render( 'invalid', path => $req->uri->path ) );
}
sub render {
my ( $self, $action, %args ) = @_;
my $page = $self->cache->{$action} || do {
$self->cache->{$action} = $self->template->compile(
file => File::Spec->catfile( $self->viewdir, "$action.msn" ) );
};
$page->(%args);
}
sub do_get {
my ( $self, $req ) = @_;
my $status = 403;
if ( my $mode = $req->param('mode') ) {
if ( $mode eq 'next' ) {
$status = 410;
}
elsif ( $mode eq 'prev' ) {
$status = 418;
}
}
return ( $status, {}, $self->render( 'get', status => $status ) );
}
*do_head = \&do_get;
sub do_post {
my ( $self, $req ) = @_;
my $status = $req->param('money') ? 503 : 400;
my $wait = int( rand(5) ) * 10 + 30;
return ( $status, {},
$self->render( 'post', status => $status, wait => $wait ) );
}
sub do_put {
my ( $self, $req ) = @_;
return ( 201, {}, $self->render('put') );
}
sub do_delete {
my ( $self, $req ) = @_;
return ( 405, {}, $self->render('delete') );
}
sub do_options {
my ( $self, $req ) = @_;
return ( 200, { Allow => 'GET, HEAD, POST, PUT, OPTIONS' } );
}
__PACKAGE__->meta->make_immutable;
1;
<!DOCTYPE html>
<html>
<head><title>405 Method Not Allowed</title></head>
<body>
<h1>食べ物を粗末にすることは許されません</h1>
<p>うどんを捨てるとか意味がわからん。食えよ。汁の一滴、麺の一本たりとも残すとか有り得ないだろ。</p>
</body>
</html>
package Test::HTTP::Engine;
use strict;
use warnings;
use Exporter;
use HTTP::Engine::Test::Request;
our @ISA = qw(Exporter);
our @EXPORT = qw(engine get);
my $e;
sub engine (&) {
my $handler = shift;
$e = HTTP::Engine->new(
interface => {
module => 'Test',
request_handler => $handler->(),
}
);
}
sub request {
my ( $path, $method ) = @_;
my $req = HTTP::Engine::Test::Request->new(
uri => "http://example.org/$path",
method => $method,
);
$e->run( $req, env => \%ENV );
}
sub get {
my $path = shift;
request $path, 'GET';
}
1;
__END__
<!DOCTYPE html>
<html>
<% if ( $ARGS{status} == 410 ) { %>
<head><title>410 Gone</title></head>
<body>
<h1>売り切れです</h1>
<p>いやぁ、うまかった。あーあんた、残念だったね。</p>
</body>
<% } elsif ( $ARGS{status} == 418 ) { %>
<head><title>418 I'm a teapod</title></head>
<body>
<h1>うどん鍋とティーポットを間違えました</h1>
<p>というかどうやったらそんな間違いをするんですか。</p>
<p>そもそもここはうどん屋ではなく喫茶店です。</p>
</body>
<% } else { %>
<head><title>403 Forbidden</title></head>
<body>
<h1>一見さんはお断りです</h1>
<p>悪いねぇ、お前さんに食わせるうどんはねぇんだよ。ま、<a href="http://imagesearch.livedoor.com/search/?q=%E3%81%86%E3%81%A9%E3%82%93">写真でも見て</a>我慢しな。</p>
<form action='' method='post'>
<input type="submit" value="そこをなんとか、食わせてくれよ" />
</form>
</body>
<% } %>
</html>
package Udon::Handler;
use Any::Moose;
extends 'HTTP::Engine::Interface::ModPerl';
no Any::Moose;
use Udon::App;
use Udon::URLMap;
sub create_engine {
my ( $class, $r, $context_key ) = @_;
my $app = UdonMap->new( prefix => $ENV{APP_LOCATION} );
$app->map(
'/resource/udon',
sub {
NetaKit::Udon::App->new(
{ viewdir => "$ENV{APP_BASE_DIR}/view/resource/udon" } );
}
);
$app->setup_engine( { module => 'ModPerl' } );
}
__PACKAGE__->meta->make_immutable;
1;
<!DOCTYPE html>
<html>
<head><title>404 Not Found</title></head>
<body>
<h1>そんなの無いよ</h1>
<p><%= $ARGS{path} %>ってのが無いみたいだよ</p>
</body>
</html>
<!DOCTYPE html>
<html>
<% if ( $ARGS{status} == 503 ) { %>
<head><title>503 Service Unavailable</title></head>
<body>
<h1>うどん屋は大変混雑しています</h1>
<p>こちらが最後尾: 只今の待ち時間 <%= $ARGS{wait} %>分</p>
</body>
<% } else { %>
<head><title>400 Bad Request</title></head>
<body>
<h1>お金を払って下さい</h1>
<p>食い逃げは犯罪だぞ坊主。</p>
<dl>
<dt>かけ</dt><dd>1400円</dd>
<dt>きつね</dt><dd>1600円</dd>
<dt>海老天</dt><dd>2200円</dd>
</dl>
<div>
<form action="" method="post">
<label for="money">代金</label>:
<input type="text" name="money" id="money" />円
<input type="submit" value="支払う" />
</form>
</div>
</body>
<% } %>
</html>
<!DOCTYPE html>
<html>
<head><title>201 Created</title></head>
<body>
<h1>うどんが出来ました</h1>
<p>いや、うどんは出来たけどよ、うち、うどん屋なんだよ。なんでうちに持ってくるんだよ。それこそ売るほど有んだけどよう。</p>
</body>
</html>
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use HTTP::Engine;
use HTTP::Engine::Middleware;
use Udon::App;
my $mw = HTTP::Engine::Middleware->new;
$mw->install(
'Udon::Middleware::URLMap' => {
path => '/resource/udon',
app => Udon::App->new( { viewdir => "$FindBin::Bin/../view" } ),
},
);
HTTP::Engine->new(
interface => {
module => 'ServerSimple',
args => {
host => 'localhost',
port => 9393,
},
request_handler => $mw->handler(
sub {
my $req = shift;
return HTTP::Engine::Response->new(
status => 404,
body => sprintf( 'Not Found: %s', $req->uri->path )
);
}
),
}
)->run;
1;
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use feature 'switch';
use HTTP::Engine;
use Udon::App;
my %apps = ( udon => Udon::App->new( { viewdir => "$FindBin::Bin/../view" } ) );
HTTP::Engine->new(
interface => {
module => 'ServerSimple',
args => {
host => 'localhost',
port => 9393,
},
request_handler => sub {
my $req = shift;
given ( $req->uri->path ) {
when (m{^/resource/udon}) {
return $apps{udon}->handle_request($req);
}
default {
return HTTP::Engine::Response->new(
status => 404,
body => sprintf( 'Not Found: %s', $req->uri->path ),
);
}
}
},
},
)->run;
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use Udon::App;
use Udon::URLMap;
my $app = Udon::URLMap->new;
$app->map( '/resource/udon', Udon::App->new( { viewdir => "$FindBin::Bin/../view" } ) );
$app->setup_engine(
{
module => 'ServerSimple',
args => {
host => 'localhost',
port => 9393,
},
}
)->run;
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use HTTP::Engine;
use Udon::App;
my %apps = ( udon => Udon::App->new( { viewdir => "$FindBin::Bin/../view" } ) );
HTTP::Engine->new(
interface => {
module => 'ServerSimple',
args => {
host => 'localhost',
port => 9393,
},
request_handler => sub {
my $req = shift;
if ( $req->uri->path =~ m{^/resource/udon} ) {
return $apps{udon}->handle_request($req);
}
else {
return HTTP::Engine::Response->new(
status => 404,
body => sprintf( 'Not Found: %s', $req->uri->path ),
);
}
},
},
)->run;
#!/usr/bin/env perl
# vim: ft=perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/lib";
use Udon::App;
Udon::App->new( { viewdir => "$FindBin::Bin/view" } )->setup_engine(
{
module => 'CGI',
args => {},
}
)->run;
package Udon::Middleware::URLMap;
use HTTP::Engine::Middleware;
has 'prefix' => (
is => 'ro',
isa => 'Str|Undef',
);
has 'path' => (
is => 'ro',
isa => 'Str',
required => 1,
);
has 'app' => (
is => 'ro',
isa => 'Object',
required => 1,
);
before_handle {
my ( $c, $self, $req ) = @_;
my $uri_path = $req->uri->path;
my $app_path = $self->path;
$app_path = $self->prefix . $self->path if $self->prefix;
return $req unless $uri_path && $uri_path =~ /^(?:$app_path)/;
return $self->app->handle_request($req);
};
__MIDDLEWARE__
package Udon::URLMap;
use Any::Moose;
use Path::Dispatcher;
has 'dispatcher' => (
is => 'ro',
default => sub { Path::Dispatcher->new; }
);
has 'prefix' => (
is => 'ro',
isa => 'Str',
);
no Any::Moose;
sub setup_engine {
my ( $self, $conf ) = @_;
$conf->{request_handler} = sub { $self->handle_request(@_) };
HTTP::Engine->new( interface => $conf, );
}
sub handle_request {
my ( $self, $req ) = @_;
my $dispatch = $self->dispatcher->dispatch( $req->uri->path );
unless ( $dispatch->has_matches ) {
return HTTP::Engine::Response->new(
status => 404,
body => sprintf( 'Not Found: %s', $req->uri->path )
);
}
my $res;
eval { $res = $dispatch->run($req) };
if ($@) {
$res = HTTP::Engine::Response->new(
status => 500,
body => 'Internal Server Error',
);
}
return $res;
}
sub map {
my ( $self, $path, $app ) = @_;
$path = $self->prefix . $path if $self->prefix;
$app = $app->() if ref($app) eq 'CODE';
$self->dispatcher->add_rule(
Path::Dispatcher::Rule::Regex->new(
regex => qr/^$path/,
block => sub { $app->handle_request(@_) },
)
);
}
__PACKAGE__->meta->make_immutable;
1;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment