00.load.t

use strict;
use Test::More tests => 1;

BEGIN {
    use_ok 'Udon::App';
}

01.udon.t

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';

01.udon_declare.t

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';
    };
};

01.udon_hetest.t

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;
    };
};

App.pm

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;

delete.msn

<!DOCTYPE html>
<html>
<head><title>405 Method Not Allowed</title></head>
<body>
<h1>食べ物を粗末にすることは許されません</h1>
<p>うどんを捨てるとか意味がわからん。食えよ。汁の一滴、麺の一本たりとも残すとか有り得ないだろ。</p>
</body>
</html>

Engine.pm

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__

get.msn

<!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>

Handler.pm

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;

invalid.msn

<!DOCTYPE html>
<html>
<head><title>404 Not Found</title></head>
<body>
<h1>そんなの無いよ</h1>
<p><%= $ARGS{path} %>ってのが無いみたいだよ</p>
</body>
</html>

post.msn

<!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>

put.msn

<!DOCTYPE html>
<html>
<head><title>201 Created</title></head>
<body>
<h1>うどんが出来ました</h1>
<p>いや、うどんは出来たけどよ、うち、うどん屋なんだよ。なんでうちに持ってくるんだよ。それこそ売るほど有んだけどよう。</p>
</body>
</html>

server-middleware.pl

#!/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;

server-switch.pl

#!/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;

server-urlmap.pl

#!/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;

server.pl

#!/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;

udon.cgi

#!/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;

URLMap.pm

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__

URLMap.pm

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;