From 8f662a759cc3ba3ab61d4e5fc6de546593dc897d Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 14 Oct 2009 17:00:19 -0700 Subject: [PATCH] initial commit --- .gitignore | 5 + .shipit | 2 + Changes | 4 + MANIFEST | 31 +++++++ MANIFEST.SKIP | 14 +++ Makefile.PL | 18 ++++ README | 63 +++++++++++++ eg/demo.pl | 52 +++++++++++ lib/Tatsumaki.pm | 82 +++++++++++++++++ lib/Tatsumaki/Application.pm | 82 +++++++++++++++++ lib/Tatsumaki/Error.pm | 22 +++++ lib/Tatsumaki/HTTPClient.pm | 45 +++++++++ lib/Tatsumaki/Handler.pm | 63 +++++++++++++ lib/Tatsumaki/Server.pm | 174 +++++++++++++++++++++++++++++++++++ t/00_compile.t | 4 + xt/perlcritic.t | 5 + xt/pod.t | 4 + xt/podspell.t | 9 ++ xt/synopsis.t | 4 + 19 files changed, 683 insertions(+) create mode 100644 .gitignore create mode 100644 .shipit create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 Makefile.PL create mode 100644 README create mode 100755 eg/demo.pl create mode 100644 lib/Tatsumaki.pm create mode 100644 lib/Tatsumaki/Application.pm create mode 100644 lib/Tatsumaki/Error.pm create mode 100644 lib/Tatsumaki/HTTPClient.pm create mode 100644 lib/Tatsumaki/Handler.pm create mode 100644 lib/Tatsumaki/Server.pm create mode 100644 t/00_compile.t create mode 100644 xt/perlcritic.t create mode 100644 xt/pod.t create mode 100644 xt/podspell.t create mode 100644 xt/synopsis.t diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..aa7964e --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +META.yml +Makefile +inc/ +pm_to_blib +*~ diff --git a/.shipit b/.shipit new file mode 100644 index 0000000..d2778c7 --- /dev/null +++ b/.shipit @@ -0,0 +1,2 @@ +steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN +git.push_to = origin diff --git a/Changes b/Changes new file mode 100644 index 0000000..c8a2086 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for Perl extension Tatsumaki + +0.01 Wed Oct 14 13:58:56 2009 + - original version diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..7988f7d --- /dev/null +++ b/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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..54c53b5 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,14 @@ +\bRCS\b +\bCVS\b +\.svn/ +\.git/ +^MANIFEST\. +^Makefile$ +~$ +\.old$ +^blib/ +^pm_to_blib +^MakeMaker-\d +\.gz$ +\.cvsignore +\.shipit diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..8f5b839 --- /dev/null +++ b/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; diff --git a/README b/README new file mode 100644 index 0000000..a30e53e --- /dev/null +++ b/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 + +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 + diff --git a/eg/demo.pl b/eg/demo.pl new file mode 100755 index 0000000..9ad887e --- /dev/null +++ b/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("

Fetched " . scalar(@{$json->{entries}}) . " entries from API

"); + for my $entry (@{$json->{entries}}) { + $self->write("
  • " . $entry->{body} . "
    • "); + } + $self->finish; +} + +package main; + +my $app = Tatsumaki::Application->new([ + '/feed/(\w+)' => 'SearchHandler', + '/' => 'MainHandler', +]); + +Tatsumaki::Server->new(port => 9999)->run($app); diff --git a/lib/Tatsumaki.pm b/lib/Tatsumaki.pm new file mode 100644 index 0000000..d162760 --- /dev/null +++ b/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 Emiyagawa@bulknews.netE + +=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 L L L + +=cut diff --git a/lib/Tatsumaki/Application.pm b/lib/Tatsumaki/Application.pm new file mode 100644 index 0000000..c62af9c --- /dev/null +++ b/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; + + diff --git a/lib/Tatsumaki/Error.pm b/lib/Tatsumaki/Error.pm new file mode 100644 index 0000000..15a1997 --- /dev/null +++ b/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; + diff --git a/lib/Tatsumaki/HTTPClient.pm b/lib/Tatsumaki/HTTPClient.pm new file mode 100644 index 0000000..026fad3 --- /dev/null +++ b/lib/Tatsumaki/HTTPClient.pm @@ -0,0 +1,45 @@ +package Tatsumaki::HTTPClient; +use strict; +use AnyEvent::HTTP (); +use HTTP::Request::Common (); +use HTTP::Request; +use HTTP::Response; +use Moose; + +has timeout => (is => 'rw', isa => 'Int', default => sub { 30 }); +has agent => (is => 'rw', isa => 'Str', default => sub { join "/", __PACKAGE__, $Tatsumaki::VERSION }); + +sub get { _request(GET => @_) } +sub head { _request(HEAD => @_) } +sub post { _request(POST => @_) } +sub put { _request(PUT => @_) } +sub delete { _request(DELETE => @_) } + +sub _request { + my $cb = pop; + my $method = shift; + my $self = shift; + no strict 'refs'; + my $req = &{"HTTP::Request::Common::$method"}(@_); + $self->request($req, $cb); +} + +sub request { + my($self, $request, $cb) = @_; + + my $headers = $request->headers; + $headers->{'user-agent'} = $self->agent; + + AnyEvent::HTTP::http_request $request->method, $request->uri, + timeout => $self->timeout, headers => $headers, sub { + my($body, $header) = @_; + my $res = HTTP::Response->new($header->{Status}, $header->{Reason}, [ %$header ], $body); + $cb->($res); + }; +} + + +no Moose; +__PACKAGE__->meta->make_immutable; + +1; diff --git a/lib/Tatsumaki/Handler.pm b/lib/Tatsumaki/Handler.pm new file mode 100644 index 0000000..246aa53 --- /dev/null +++ b/lib/Tatsumaki/Handler.pm @@ -0,0 +1,63 @@ +package Tatsumaki::Handler; +use strict; +use Encode; +use Moose; + +has application => (is => 'rw', isa => 'Tatsumaki::Application'); +has condvar => (is => 'rw', isa => 'AnyEvent::CondVar'); +has request => (is => 'rw', isa => 'Plack::Request'); +has response => (is => 'rw', isa => 'Plack::Response', lazy_build => 1); +has args => (is => 'rw', isa => 'ArrayRef'); + +has _write_buffer => (is => 'rw', isa => 'ArrayRef', lazy => 1, default => sub { [] }); + +my $class_attr = {}; + +sub is_nonblocking { + my $class = ref $_[0] || $_[0]; + return $class_attr->{$class}{is_nonblocking}; +} + +sub nonblocking { + my $class = shift; + $class_attr->{$class}{is_nonblocking} = shift; +} + +sub _build_response { + my $self = shift; + $self->request->new_response(200, [ 'Content-Type' => 'text/plain; charset=utf-8' ]); +} + +sub run { + my $self = shift; + my $method = lc $self->request->method; + # TODO supported_methods + $self->$method(@{$self->args}); + $self->finish unless $self->is_nonblocking; +} + +sub write { + my $self = shift; + push @{$self->_write_buffer}, map Encode::encode_utf8($_), @_; +} + +sub flush { + my $self = shift; + # FIXME do something else in non-blocking + my $body = $self->response->body || []; + push @$body, @{$self->_write_buffer}; + $self->_write_buffer([]); + $self->response->body($body); +} + +sub finish { + my $self = shift; + $self->flush; + $self->condvar->send($self->response->finalize); +} + +no Moose; +__PACKAGE__->meta->make_immutable; + +1; +__END__ diff --git a/lib/Tatsumaki/Server.pm b/lib/Tatsumaki/Server.pm new file mode 100644 index 0000000..d730317 --- /dev/null +++ b/lib/Tatsumaki/Server.pm @@ -0,0 +1,174 @@ +# just a clone of Plack::Server::AnyEvent for now +# removed AIO support and ContentLength middleware +package Tatsumaki::Server; +use strict; +use warnings; +use 5.008_001; + +use AnyEvent; +use AnyEvent::Handle; +use AnyEvent::Socket; +use Carp (); +use Plack::Util; +use HTTP::Status; +use Plack::HTTPParser qw(parse_http_request); +use IO::Handle; +use Errno (); +use Scalar::Util (); +use Socket qw(IPPROTO_TCP TCP_NODELAY); + +sub new { + my($class, %args) = @_; + + my $self = bless {}, $class; + $self->{host} = delete $args{host} || undef; + $self->{port} = delete $args{port} || undef; + + $self; +} + +sub register_service { + my($self, $app) = @_; + + my $guard = tcp_server $self->{host}, $self->{port}, sub { + + my ( $sock, $peer_host, $peer_port ) = @_; + + if ( !$sock ) { + return; + } + setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, 1) + or die "setsockopt(TCP_NODELAY) failed:$!"; + + my $env = { + SERVER_PORT => $self->{prepared_port}, + SERVER_NAME => $self->{prepared_host}, + SCRIPT_NAME => '', + 'psgi.version' => [ 1, 0 ], + 'psgi.errors' => *STDERR, + 'psgi.url_scheme' => 'http', + 'psgi.nonblocking' => Plack::Util::TRUE, + 'psgi.run_once' => Plack::Util::FALSE, + 'psgi.multithread' => Plack::Util::FALSE, + 'psgi.multiprocess' => Plack::Util::FALSE, + REMOTE_ADDR => $peer_host, + }; + + # Note: broken pipe in test is maked by Test::TCP. + my $handle; + $handle = AnyEvent::Handle->new( + fh => $sock, + timeout => 3, + on_eof => sub { undef $handle; undef $env; }, + on_error => sub { undef $handle; undef $env; warn $! if $! != Errno::EPIPE }, + on_timeout => sub { undef $handle; undef $env; }, + ); + + my $parse_header; + $parse_header = sub { + my ( $handle, $chunk ) = @_; + my $reqlen = parse_http_request($chunk . "\015\012", $env); + if ($reqlen < 0) { + $self->_write_headers($handle, 400, [ 'Content-Type' => 'text/plain' ]); + $handle->push_write("400 Bad Request"); + } else { + my $response_handler = $self->_response_handler($handle, $sock); + if ($env->{CONTENT_LENGTH} && $env->{REQUEST_METHOD} =~ /^(?:POST|PUT)$/) { + # Slurp content + $handle->push_read( + chunk => $env->{CONTENT_LENGTH}, sub { + my ($handle, $data) = @_; + open my $input, "<", \$data; + $env->{'psgi.input'} = $input; + $response_handler->($app, $env); + } + ); + } else { + open my $input, "<", \""; + $env->{'psgi.input'} = $input; + $response_handler->($app, $env); + } + } + }; + + $handle->unshift_read( line => qr{(?{prepared_host} = $host; + $self->{prepared_port} = $port; + warn "Accepting requests at http://$host:$port/\n"; + return 0; + }; + $self->{listen_guard} = $guard; +} + +sub _write_headers { + my($self, $handle, $status, $headers) = @_; + + my $hdr; + $hdr .= "HTTP/1.0 $status @{[ HTTP::Status::status_message($status) ]}\015\012"; + while (my ($k, $v) = splice(@$headers, 0, 2)) { + $hdr .= "$k: $v\015\012"; + } + $hdr .= "\015\012"; + + $handle->push_write($hdr); +} + +sub _response_handler { + my($self, $handle, $sock) = @_; + + Scalar::Util::weaken($sock); + + return sub { + my($app, $env) = @_; + my $res = Plack::Util::run_app $app, $env; + + # PSGI standard + if (ref $res eq 'ARRAY') { + $self->_write_response($res, $handle, $sock); + } elsif (Scalar::Util::blessed($res) && $res->can('cb')) { + $res->cb(sub { + my $res = $res->recv; + $self->_write_response($res, $handle, $sock); + }); + } else { + Carp::carp("Unknown response type: $res"); + } + }; +} + +sub _write_response { + my($self, $res, $handle, $sock) = @_; + + $self->_write_headers($handle, $res->[0], $res->[1]); + + my $body = $res->[2]; + my $disconnect_cb = sub { $handle->on_drain(sub { $handle->destroy }) }; + + if ( ref $body eq 'GLOB' ) { + no warnings 'recursion'; + $handle->on_drain(sub { + my $read = $body->read(my $buf, 4096); + $handle->push_write($buf); + if ($read == 0) { + $body->close; + $handle->on_drain; + $handle->destroy; + } + }); + } else { + Plack::Util::foreach( $body, sub { $handle->push_write($_[0]) } ); + $disconnect_cb->(); + } +} + +sub run { + my $self = shift; + $self->register_service(@_); + AnyEvent->condvar->recv; +} + +1; +__END__ diff --git a/t/00_compile.t b/t/00_compile.t new file mode 100644 index 0000000..4fe8f4d --- /dev/null +++ b/t/00_compile.t @@ -0,0 +1,4 @@ +use strict; +use Test::More tests => 1; + +BEGIN { use_ok 'Tatsumaki' } diff --git a/xt/perlcritic.t b/xt/perlcritic.t new file mode 100644 index 0000000..950f64f --- /dev/null +++ b/xt/perlcritic.t @@ -0,0 +1,5 @@ +use strict; +use Test::More; +eval q{ use Test::Perl::Critic }; +plan skip_all => "Test::Perl::Critic is not installed." if $@; +all_critic_ok("lib"); diff --git a/xt/pod.t b/xt/pod.t new file mode 100644 index 0000000..437887a --- /dev/null +++ b/xt/pod.t @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/xt/podspell.t b/xt/podspell.t new file mode 100644 index 0000000..c4f1f21 --- /dev/null +++ b/xt/podspell.t @@ -0,0 +1,9 @@ +use Test::More; +eval q{ use Test::Spelling }; +plan skip_all => "Test::Spelling is not installed." if $@; +add_stopwords(); +set_spell_cmd("aspell -l en list"); +all_pod_files_spelling_ok('lib'); +__DATA__ +Tatsuhiko +Miyagawa diff --git a/xt/synopsis.t b/xt/synopsis.t new file mode 100644 index 0000000..07aa750 --- /dev/null +++ b/xt/synopsis.t @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::Synopsis"; +plan skip_all => "Test::Synopsis required" if $@; +all_synopsis_ok();