initial commit

.gitignore

@@ -0,0 +1,5 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~

.shipit

@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin

Changes

@@ -0,0 +1,4 @@
+Revision history for Perl extension Tatsumaki
+
+0.01  Wed Oct 14 13:58:56 2009
+        - original version

MANIFEST

@@ -0,0 +1,31 @@
+.gitignore
+Changes
+inc/Module/Install.pm
+inc/Module/Install/AuthorTests.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/Repository.pm
+inc/Module/Install/TestBase.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+inc/Spiffy.pm
+inc/Test/Base.pm
+inc/Test/Base/Filter.pm
+inc/Test/Builder.pm
+inc/Test/Builder/Module.pm
+inc/Test/More.pm
+lib/Tatsumaki.pm
+Makefile.PL
+MANIFEST			This list of files
+META.yml
+README
+t/00_compile.t
+xt/perlcritic.t
+xt/pod.t
+xt/podspell.t
+xt/synopsis.t

MANIFEST.SKIP

@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit

Makefile.PL

@@ -0,0 +1,18 @@
+use inc::Module::Install;
+name 'Tatsumaki';
+all_from 'lib/Tatsumaki.pm';
+readme_from 'lib/Tatsumaki.pm';
+requires 'AnyEvent';
+requires 'AnyEvent::HTTP';
+requires 'Moose';
+requires 'Path::Dispatcher';
+requires 'Plack';
+requires 'Throwable';
+requires 'JSON';
+build_requires 'Test::More';
+use_test_base;
+auto_include_deps;
+auto_install;
+author_tests('xt');
+auto_set_repository;
+WriteAll;

README

@@ -0,0 +1,63 @@
+NAME
+    Tatsumaki - Non-blocking Web server and framework based on AnyEvent and
+    PSGI
+
+SYNOPSIS
+      use Tatsumaki;
+      use Tatsumaki::Error;
+      use Tatsumaki::Application;
+      use Tatsumaki::HTTPClient;
+      use Tatsumaki::Server;
+      use JSON;
+
+      package MainHandler;
+      use base qw(Tatsumaki::Handler);
+
+      sub get {
+          my $self = shift;
+          $self->write("Hello World");
+      }
+
+      package SearchHandler;
+      use base qw(Tatsumaki::Handler);
+
+      __PACKAGE__->nonblocking(1);
+
+      sub get {
+          my($self, $query) = @_;
+          my $client = Tatsumaki::HTTPClient->new;
+          $client->get("http://friendfeed-api.com/v2/feed/$query", sub { $self->on_response(@_) });
+      }
+
+      sub on_response {
+          my($self, $res) = @_;
+          if ($res->is_error) {
+              Tatsumaki::Error::HTTP->throw(500);
+          }
+          my $json = JSON::decode_json($res->content);
+          $self->write("Fetched " . scalar(@{$json->{entries}}) . " entries from API");
+          $self->finish;
+      }
+
+      package main;
+
+      my $app = Tatsumaki::Application->new([
+          '/feed/(\w+)' => 'SearchHandler',
+          '/' => 'MainHandler',
+      ]);
+
+      Tatsumaki::Server->new(port => 9999)->run($app);
+
+DESCRIPTION
+    Tatsumaki is a toy port of Tornado for Perl using PSGI and AnyEvent.
+
+AUTHOR
+    Tatsuhiko Miyagawa <miyagawa@bulknews.net>
+
+LICENSE
+    This library is free software; you can redistribute it and/or modify it
+    under the same terms as Perl itself.
+
+SEE ALSO
+    AnyEvent Plack PSGI <http://www.tornadoweb.org/>
+

eg/demo.pl

@@ -0,0 +1,52 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Tatsumaki;
+use Tatsumaki::Error;
+use Tatsumaki::Application;
+use Tatsumaki::HTTPClient;
+use Tatsumaki::Server;
+use JSON;
+
+package MainHandler;
+use base qw(Tatsumaki::Handler);
+
+sub get {
+    my $self = shift;
+    $self->write("Hello World");
+}
+
+package SearchHandler;
+use base qw(Tatsumaki::Handler);
+
+__PACKAGE__->nonblocking(1);
+
+sub get {
+    my($self, $query) = @_;
+    my $client = Tatsumaki::HTTPClient->new;
+    $client->get("http://friendfeed-api.com/v2/feed/$query", sub { $self->on_response(@_) });
+}
+
+sub on_response {
+    my($self, $res) = @_;
+    if ($res->is_error) {
+        Tatsumaki::Error::HTTP->throw(500);
+    }
+    my $json = JSON::decode_json($res->content);
+
+    $self->response->content_type('text/html;charset=utf-8');
+    $self->write("<p>Fetched " . scalar(@{$json->{entries}}) . " entries from API</p>");
+    for my $entry (@{$json->{entries}}) {
+        $self->write("<li>" . $entry->{body} . "</li>");
+    }
+    $self->finish;
+}
+
+package main;
+
+my $app = Tatsumaki::Application->new([
+    '/feed/(\w+)' => 'SearchHandler',
+    '/' => 'MainHandler',
+]);
+
+Tatsumaki::Server->new(port => 9999)->run($app);

lib/Tatsumaki.pm

@@ -0,0 +1,82 @@
+package Tatsumaki;
+
+use strict;
+use 5.008_001;
+our $VERSION = '0.01';
+
+1;
+__END__
+
+=encoding utf-8
+
+=for stopwords
+
+=head1 NAME
+
+Tatsumaki - Non-blocking Web server and framework based on AnyEvent and PSGI
+
+=head1 SYNOPSIS
+
+  use Tatsumaki;
+  use Tatsumaki::Error;
+  use Tatsumaki::Application;
+  use Tatsumaki::HTTPClient;
+  use Tatsumaki::Server;
+  use JSON;
+
+  package MainHandler;
+  use base qw(Tatsumaki::Handler);
+
+  sub get {
+      my $self = shift;
+      $self->write("Hello World");
+  }
+
+  package SearchHandler;
+  use base qw(Tatsumaki::Handler);
+
+  __PACKAGE__->nonblocking(1);
+
+  sub get {
+      my($self, $query) = @_;
+      my $client = Tatsumaki::HTTPClient->new;
+      $client->get("http://friendfeed-api.com/v2/feed/$query", sub { $self->on_response(@_) });
+  }
+
+  sub on_response {
+      my($self, $res) = @_;
+      if ($res->is_error) {
+          Tatsumaki::Error::HTTP->throw(500);
+      }
+      my $json = JSON::decode_json($res->content);
+      $self->write("Fetched " . scalar(@{$json->{entries}}) . " entries from API");
+      $self->finish;
+  }
+
+  package main;
+
+  my $app = Tatsumaki::Application->new([
+      '/feed/(\w+)' => 'SearchHandler',
+      '/' => 'MainHandler',
+  ]);
+
+  Tatsumaki::Server->new(port => 9999)->run($app);
+
+=head1 DESCRIPTION
+
+Tatsumaki is a toy port of Tornado for Perl using PSGI and AnyEvent.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<AnyEvent> L<Plack> L<PSGI> L<http://www.tornadoweb.org/>
+
+=cut

lib/Tatsumaki/Application.pm

@@ -0,0 +1,82 @@
+package Tatsumaki::Application;
+use AnyEvent;
+use Moose;
+use Path::Dispatcher;
+use Plack::Request;
+use Plack::Response;
+use Tatsumaki::Handler;
+use Try::Tiny;
+
+use overload q(&{}) => sub { shift->psgi_app }, fallback => 1;
+
+has '_dispatcher' => (is => 'rw', isa => 'Path::Dispatcher', lazy_build => 1);
+
+sub _build__dispatcher {
+    Path::Dispatcher->new;
+}
+
+around BUILDARGS => sub {
+    my $orig = shift;
+    my $class = shift;
+    if (ref $_[0] eq 'ARRAY') {
+        $class->$orig(_rules => $_[0]);
+    } else {
+        $class->$orig(@_);
+    }
+};
+
+sub BUILD {
+    my $self = shift;
+
+    my %args  = %{$_[0]};
+    my @rules = @{$args{_rules}};
+
+    my $dispatcher = $self->_dispatcher;
+    while (my($path, $handler) = splice @rules, 0, 2) {
+        $path = qr/^$path/ unless ref $path eq 'RegExp';
+        $dispatcher->add_rule(
+            Path::Dispatcher::Rule::Regex->new(
+                regex => $path,
+                block => sub {
+                    my $cb = shift;
+                    $cb->($handler, $1, $2, $3, $4, $5, $6, $7, $8, $9);
+                },
+            ),
+        );
+    }
+
+    return $self;
+}
+
+sub psgi_app {
+    my $self = shift;
+    return sub {
+        my $env = shift;
+        my $req = Plack::Request->new($env);
+        my $cv  = AE::cv;
+
+        my $dispatch = $self->_dispatcher->dispatch($req->path);
+        unless ($dispatch->has_matches) {
+            return [ 404, [ 'Content-Type' => 'text/html' ], [ "404 Not Found" ] ];
+        }
+
+        # TODO if you throw exception from nonblocking callback, there seems no way to catch it
+        $dispatch->run(sub {
+            my $handler = shift;
+            my $context = $handler->new(
+                application => $self,
+                handler => $handler,
+                request => $req,
+                args    => [ @_ ],
+                condvar => $cv,
+            );
+            $context->run;
+        });
+
+        return $cv;
+    };
+}
+
+1;
+
+

lib/Tatsumaki/Error.pm

@@ -0,0 +1,22 @@
+package Tatsumaki::Error;
+use strict;
+use Moose;
+with 'Throwable';
+
+package Tatsumaki::Error::HTTP;
+use Moose;
+use HTTP::Status;
+extends 'Tatsumaki::Error';
+
+has code => (is => 'rw', isa => 'Int');
+
+around BUILDARGS => sub {
+    my $orig = shift;
+    my($class, $code) = @_;
+    $class->$orig(code => $code);
+};
+
+package Tatsumaki::Error;
+
+1;
+