├── .gitignore ├── README.pod ├── MANIFEST.SKIP ├── xt ├── changes.t ├── pod.t └── pod-coverage.t ├── t ├── lib │ ├── Handler.pm │ └── Utils.pm ├── conn.t ├── middleware.t └── live │ ├── xhr-polling.t │ ├── jsonp-polling.t │ ├── xhr-multipart.t │ └── websocket.t ├── Changes ├── examples ├── flash-policy-server └── chat.psgi ├── Makefile.PL └── lib └── Plack └── Middleware ├── SocketIO ├── WebSocket.pm ├── Resource.pm ├── Handle.pm ├── Base.pm ├── XHRPolling.pm ├── XHRMultipart.pm ├── Htmlfile.pm ├── JSONPPolling.pm └── Connection.pm └── SocketIO.pm /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | blib 3 | *.swp 4 | *~ 5 | pm_to_blib 6 | -------------------------------------------------------------------------------- /README.pod: -------------------------------------------------------------------------------- 1 | 2 | =pod 3 | 4 | =head1 DEPRECATED 5 | 6 | Use L instead. 7 | 8 | =cut 9 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^blib 2 | ^pm_to_blib 3 | .*\.old$ 4 | ^Makefile$ 5 | ^\.git 6 | .tar.gz$ 7 | .swp$ 8 | MANIFEST.bak 9 | README.pod 10 | Debian_CPANTS.txt 11 | -------------------------------------------------------------------------------- /xt/changes.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | eval 'use Test::CPAN::Changes'; 7 | 8 | plan skip_all => 'Test::CPAN::Changes required for this test' if $@; 9 | 10 | changes_ok(); 11 | -------------------------------------------------------------------------------- /t/lib/Handler.pm: -------------------------------------------------------------------------------- 1 | package Handler; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | return bless {}, $class; 10 | } 11 | 12 | sub run { 13 | my $self = shift; 14 | 15 | return sub { 16 | }; 17 | } 18 | 19 | 1; 20 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | # Ensure a recent version of Test::Pod 7 | my $min_tp = 1.22; 8 | eval "use Test::Pod $min_tp"; 9 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 10 | 11 | all_pod_files_ok(); 12 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for perl module Plack::Middleware::SocketIO 2 | 3 | 0.009004 4 | 5 | - DEPRECATED. Use PocketIO instead 6 | 7 | 0.009003 8 | 9 | - It is possible to pass class name or instance and method instead of inline 10 | handler 11 | - Added heartbeat to WebSockets too 12 | 13 | 0.009002 2011-03-29 14 | 15 | - Fixed live tests 16 | 17 | 0.009001 2011-03-28 18 | 19 | - Fixed dependencies list 20 | 21 | 0.009000 2011-03-16 22 | 23 | - Initial release 24 | -------------------------------------------------------------------------------- /xt/pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | # Ensure a recent version of Test::Pod::Coverage 7 | my $min_tpc = 1.08; 8 | eval "use Test::Pod::Coverage $min_tpc"; 9 | plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" 10 | if $@; 11 | 12 | # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, 13 | # but older versions don't recognize some common documentation styles 14 | my $min_pc = 0.18; 15 | eval "use Pod::Coverage $min_pc"; 16 | plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" 17 | if $@; 18 | 19 | all_pod_coverage_ok(); 20 | -------------------------------------------------------------------------------- /t/conn.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 7; 5 | 6 | use_ok('Plack::Middleware::SocketIO::Connection'); 7 | 8 | my $conn = Plack::Middleware::SocketIO::Connection->new; 9 | ok $conn; 10 | 11 | my $output = ''; 12 | $conn->on_message(sub { $output .= $_[1] }); 13 | 14 | $conn->read('~m~4~m~1234'); 15 | is $output => '1234'; 16 | $output = ''; 17 | 18 | $conn->read('~m~4~m~1234~m~2~m~12'); 19 | is $output => '123412'; 20 | $output = ''; 21 | 22 | $conn->read('foobar'); 23 | is $output => ''; 24 | 25 | $conn->on_message(sub { $output = $_[1] }); 26 | 27 | $conn->read('~m~16~m~~j~{"foo":"bar"}'); 28 | is_deeply $output => {foo => 'bar'}; 29 | $output = ''; 30 | 31 | $conn->read('~m~16~m~~j~{"foo","bar"}'); 32 | is $output => ''; 33 | -------------------------------------------------------------------------------- /t/middleware.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More tests => 5; 7 | 8 | use_ok('Plack::Middleware::SocketIO'); 9 | 10 | use Handler; 11 | 12 | eval { 13 | Plack::Middleware::SocketIO->new(app => sub { }); 14 | }; 15 | like $@ => qr/Either 'handler', 'class' or 'instance' must be specified/; 16 | 17 | my $middleware = 18 | Plack::Middleware::SocketIO->new(app => sub { }, handler => sub { }); 19 | is ref($middleware->handler) => 'CODE'; 20 | 21 | $middleware = 22 | Plack::Middleware::SocketIO->new(app => sub { }, class => 'Handler'); 23 | is ref($middleware->handler) => 'CODE'; 24 | 25 | $middleware = 26 | Plack::Middleware::SocketIO->new(app => sub { }, instance => Handler->new); 27 | is ref($middleware->handler) => 'CODE'; 28 | -------------------------------------------------------------------------------- /t/live/xhr-polling.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | plan skip_all => 'set TEST_LIVE to run this test' unless $ENV{TEST_LIVE}; 10 | plan tests => 2; 11 | 12 | $ENV{TEST_TRANSPORT} = 'xhr-polling'; 13 | } 14 | 15 | use AnyEvent::Impl::Perl; 16 | use AnyEvent::HTTP; 17 | use Utils; 18 | 19 | my $id; 20 | 21 | my $init = my_http_get "//1234567890", sub { 22 | my $res = shift; 23 | 24 | ($id) = $res =~ m/^~m~16~m~(\d+)/; 25 | }; 26 | 27 | $init->recv; 28 | 29 | like $id => qr/(\d+)/; 30 | 31 | my $req1 = my_http_get "/$id/1234567891", sub { 32 | my $res = shift; 33 | 34 | warn $res; 35 | }; 36 | 37 | my $req2 = my_http_post "/$id/send", 'data=~m~5~m~hello', sub { 38 | my $res = shift; 39 | 40 | is $res => 'ok'; 41 | }; 42 | 43 | $req1->recv; 44 | $req2->recv; 45 | -------------------------------------------------------------------------------- /t/live/jsonp-polling.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | plan skip_all => 'set TEST_LIVE to run this test' unless $ENV{TEST_LIVE}; 10 | plan tests => 2; 11 | 12 | $ENV{TEST_TRANSPORT} = 'jsonp-polling'; 13 | } 14 | 15 | use AnyEvent::Impl::Perl; 16 | use AnyEvent::HTTP; 17 | use Utils; 18 | 19 | my $id; 20 | 21 | my $init = my_http_get "//1234567890/0", sub { 22 | my $res = shift; 23 | 24 | ($id) = $res =~ m/io.JSONP\[0\]\._\("~m~16~m~(\d+)"\);/; 25 | }; 26 | 27 | $init->recv; 28 | 29 | like $id => qr/(\d+)/; 30 | 31 | my $req1 = my_http_get "/$id/1234567891/0", sub { 32 | my $res = shift; 33 | 34 | warn $res; 35 | }; 36 | 37 | my $req2 = my_http_post "/$id/1234567892/0", 'data=~m~5~m~hello', sub { 38 | my $res = shift; 39 | 40 | is $res => 'ok'; 41 | }; 42 | 43 | $req1->recv; 44 | $req2->recv; 45 | -------------------------------------------------------------------------------- /t/live/xhr-multipart.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | plan skip_all => 'set TEST_LIVE to run this test' unless $ENV{TEST_LIVE}; 10 | plan tests => 3; 11 | 12 | $ENV{TEST_TRANSPORT} = 'xhr-multipart' 13 | } 14 | 15 | use AnyEvent::Impl::Perl; 16 | use AnyEvent::HTTP; 17 | use Utils; 18 | 19 | my $id; 20 | my $buffer = ''; 21 | 22 | my $stream; 23 | $stream = my_http_get_raw "/", sub { 24 | my $chunk = shift; 25 | 26 | $buffer .= $chunk; 27 | 28 | if ($buffer 29 | =~ qr{Content-Type: multipart/x-mixed-replace;boundary="socketio"}ms 30 | && $buffer =~ m/~m~16~m~(\d+)/ms) 31 | { 32 | $id = $1; 33 | 34 | like $id => qr/(\d+)/; 35 | 36 | http_post my_build_url("/$id/send"), "data=~m~5~m~hello", sub { 37 | my $res = shift; 38 | 39 | is $res => 'ok'; 40 | 41 | $stream->send; 42 | }; 43 | } 44 | }; 45 | 46 | $stream->recv; 47 | -------------------------------------------------------------------------------- /examples/flash-policy-server: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent; 7 | use AnyEvent::Socket; 8 | use AnyEvent::Handle; 9 | use Getopt::Long; 10 | 11 | die 'Must be run by root' unless $> == 0 && $< == 0; 12 | 13 | my $domain = "localhost"; 14 | my $daemonize; 15 | my $secure; 16 | 17 | GetOptions( 18 | 'daemonize' => \$daemonize, 19 | 'domain=s' => \$domain, 20 | 'secure' => \$secure 21 | ) or die "Usage:\n"; 22 | 23 | my $cv = AnyEvent->condvar; 24 | 25 | tcp_server undef, 843, sub { 26 | my ($fh, $host, $port) = @_; 27 | 28 | my $handle = AnyEvent::Handle->new(fh => $fh); 29 | 30 | my $response = <<"EOF"; 31 | 32 | 33 | 34 | 35 | 36 | 37 | EOF 38 | 39 | $handle->push_write($response); 40 | }; 41 | 42 | $cv->recv; 43 | -------------------------------------------------------------------------------- /t/live/websocket.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | plan skip_all => 'set TEST_LIVE to run this test' unless $ENV{TEST_LIVE}; 10 | plan tests => 1; 11 | 12 | $ENV{TEST_TRANSPORT} = 'websocket'; 13 | } 14 | 15 | use Protocol::WebSocket::Handshake::Client; 16 | use Protocol::WebSocket::Frame; 17 | use AnyEvent::Impl::Perl; 18 | use AnyEvent::Socket; 19 | use Utils; 20 | 21 | my $hs = 22 | Protocol::WebSocket::Handshake::Client->new(url => 23 | "ws://$ENV{TEST_HOST}:$ENV{TEST_PORT}/$ENV{TEST_RESOURCE}/$ENV{TEST_TRANSPORT}" 24 | ); 25 | my $frame = Protocol::WebSocket::Frame->new; 26 | 27 | my $cv = AnyEvent->condvar; 28 | 29 | tcp_connect $ENV{TEST_HOST}, $ENV{TEST_PORT}, sub { 30 | my ($fh) = @_ or return $cv->send; 31 | 32 | syswrite $fh, $hs->to_string; 33 | 34 | my $read_watcher; 35 | $read_watcher = AnyEvent->io( 36 | fh => $fh, 37 | poll => "r", 38 | cb => sub { 39 | my $len = sysread $fh, my $chunk, 1024, 0; 40 | 41 | $hs->parse($chunk) unless $hs->is_done; 42 | 43 | if ($hs->is_done) { 44 | $frame->append($chunk); 45 | 46 | if (my $message = $frame->next) { 47 | like $message => qr/~m~16~m~\d+/; 48 | $cv->send; 49 | } 50 | } 51 | 52 | if ($len <= 0) { 53 | undef $read_watcher; 54 | $cv->send; 55 | } 56 | } 57 | ); 58 | }; 59 | 60 | $cv->recv; 61 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use 5.008007; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use ExtUtils::MakeMaker; 9 | 10 | my ($mm) = $ExtUtils::MakeMaker::VERSION =~ /^([^_]+)/; 11 | 12 | WriteMakefile( 13 | NAME => 'Plack::Middleware::SocketIO', 14 | VERSION_FROM => 'lib/Plack/Middleware/SocketIO.pm', 15 | ABSTRACT => 'Socket.IO Plack middleware', 16 | AUTHOR => 'Viacheslav Tykhanovskyi ', 17 | 18 | ($mm < 6.3002 ? () : ('LICENSE' => 'artistic_2')), 19 | 20 | ( $mm < 6.46 21 | ? () 22 | : ( META_MERGE => { 23 | x_deprecated => 1, 24 | requires => {perl => '5.008007'}, 25 | resources => { 26 | license => 'http://dev.perl.org/licenses/', 27 | repository => 28 | 'http://github.com/vti/plack-middleware-socketio', 29 | bugtracker => 30 | 'http://github.com/vti/plack-middleware-socketio/issues' 31 | }, 32 | no_index => {directory => [qw/t/]} 33 | }, 34 | META_ADD => { 35 | build_requires => {}, 36 | configure_requires => {} 37 | }, 38 | ) 39 | ), 40 | 41 | PREREQ_PM => { 42 | 'AnyEvent' => 0, 43 | 'JSON' => 0, 44 | 'Plack' => 0, 45 | 'Protocol::WebSocket' => 0.009001, 46 | 'Scalar::Util' => 0, 47 | 'Try::Tiny' => 0 48 | }, 49 | test => {TESTS => 't/*.t t/*/*.t'} 50 | ); 51 | -------------------------------------------------------------------------------- /examples/chat.psgi: -------------------------------------------------------------------------------- 1 | BEGIN { 2 | use File::Basename (); 3 | use File::Spec (); 4 | 5 | my $root = File::Basename::dirname(__FILE__); 6 | $root = File::Spec->rel2abs($root); 7 | 8 | unshift @INC, "$root/../lib"; 9 | } 10 | 11 | use Plack::Builder; 12 | use Plack::App::File; 13 | use Plack::Middleware::Static; 14 | use Plack::Middleware::SocketIO; 15 | 16 | my $path_to_socket_io = "/path/to/Socket.IO-node"; 17 | 18 | builder { 19 | mount '/socket.io/socket.io.js' => Plack::App::File->new( 20 | file => "$path_to_socket_io/support/socket.io-client/socket.io.js"); 21 | 22 | mount '/' => builder { 23 | enable "Static", 24 | path => qr/\.(?:js|css|jpe?g|gif|png|html?|js|css|swf|ico)$/, 25 | root => "$path_to_socket_io/example"; 26 | 27 | enable "SimpleLogger", level => 'debug'; 28 | 29 | enable "SocketIO", handler => sub { 30 | my $self = shift; 31 | 32 | $self->on_message( 33 | sub { 34 | my $self = shift; 35 | my ($message) = @_; 36 | 37 | $self->send_broadcast({message => [$self->id, $message]}); 38 | } 39 | ); 40 | 41 | $self->on_disconnect( 42 | sub { 43 | $self->send_broadcast( 44 | {announcement => $self->id . ' disconnected'}); 45 | } 46 | ); 47 | 48 | $self->send_message({buffer => []}); 49 | 50 | $self->send_broadcast({announcement => $self->id . ' connected'}); 51 | }; 52 | 53 | sub { 54 | [ 200, 55 | ['Content-Type' => 'text/html'], 56 | ['Open chat.'] 57 | ]; 58 | }; 59 | }; 60 | }; 61 | -------------------------------------------------------------------------------- /t/lib/Utils.pm: -------------------------------------------------------------------------------- 1 | package Utils; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | BEGIN { 7 | $ENV{TEST_HOST} ||= 'localhost'; 8 | $ENV{TEST_PORT} ||= 8080; 9 | $ENV{TEST_RESOURCE} ||= 'socket.io'; 10 | die 'set TEST_TRANSPORT' unless $ENV{TEST_TRANSPORT}; 11 | } 12 | 13 | use base 'Exporter'; 14 | 15 | use AnyEvent; 16 | use AnyEvent::Socket; 17 | use AnyEvent::HTTP; 18 | 19 | our @EXPORT = qw(my_build_url my_http_get my_http_get_raw my_http_post); 20 | 21 | sub my_build_url { 22 | my $path = shift; 23 | 24 | my $base = "http://$ENV{TEST_HOST}:$ENV{TEST_PORT}/$ENV{TEST_RESOURCE}"; 25 | my $transport = $ENV{TEST_TRANSPORT}; 26 | 27 | return "$base/$transport$path"; 28 | } 29 | 30 | sub my_http_req($@); 31 | 32 | sub my_http_get($@) { my_http_req 'GET', @_ } 33 | sub my_http_post($@) { my_http_req 'POST', @_ } 34 | 35 | sub my_http_req($@) { 36 | my $method = shift; 37 | my $path = shift; 38 | my $cb = pop @_; 39 | 40 | my $cv = AnyEvent->condvar; 41 | 42 | http_request $method, my_build_url($path), @_, sub { 43 | $cb->(@_); 44 | $cv->send; 45 | }; 46 | 47 | return $cv; 48 | } 49 | 50 | sub my_http_get_raw($@) { 51 | my $path = shift; 52 | my $cb = pop @_; 53 | 54 | my $cv = AnyEvent->condvar; 55 | 56 | tcp_connect $ENV{TEST_HOST}, $ENV{TEST_PORT}, sub { 57 | my ($fh) = @_ or return $cv->send; 58 | 59 | syswrite $fh, "GET /$ENV{TEST_RESOURCE}/$ENV{TEST_TRANSPORT}$path HTTP/1.1\015\012"; 60 | syswrite $fh, "Host: $ENV{TEST_HOST}:$ENV{TEST_PORT}\015\012"; 61 | syswrite $fh, "\015\012"; 62 | 63 | my $response = ''; 64 | 65 | my $read_watcher; 66 | $read_watcher = AnyEvent->io( 67 | fh => $fh, 68 | poll => "r", 69 | cb => sub { 70 | my $len = sysread $fh, $response, 1024, length $response; 71 | 72 | $cb->($response); 73 | 74 | if ($len <= 0) { 75 | 76 | undef $read_watcher; 77 | $cv->send($response); 78 | } 79 | } 80 | ); 81 | }; 82 | 83 | return $cv; 84 | } 85 | 86 | 1; 87 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/WebSocket.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::WebSocket; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::SocketIO::Base'; 7 | 8 | use Protocol::WebSocket::Frame; 9 | use Protocol::WebSocket::Handshake::Server; 10 | 11 | use Plack::Middleware::SocketIO::Handle; 12 | 13 | sub name {'websocket'} 14 | 15 | sub finalize { 16 | my $self = shift; 17 | my ($cb) = @_; 18 | 19 | my $fh = $self->req->env->{'psgix.io'}; 20 | return unless $fh; 21 | 22 | my $hs = Protocol::WebSocket::Handshake::Server->new_from_psgi($self->req->env); 23 | return unless $hs->parse($fh); 24 | 25 | return unless $hs->is_done; 26 | 27 | my $handle = $self->_build_handle($fh); 28 | my $frame = Protocol::WebSocket::Frame->new; 29 | 30 | return sub { 31 | my $respond = shift; 32 | 33 | $handle->write( 34 | $hs->to_string => sub { 35 | my $handle = shift; 36 | 37 | my $conn = $self->add_connection(on_connect => $cb); 38 | 39 | $handle->heartbeat_timeout(10); 40 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 41 | 42 | $handle->on_read( 43 | sub { 44 | my $handle = shift; 45 | 46 | $frame->append($_[0]); 47 | 48 | while (my $message = $frame->next) { 49 | $conn->read($message); 50 | } 51 | } 52 | ); 53 | 54 | $handle->on_eof( 55 | sub { 56 | $handle->close; 57 | 58 | $self->client_disconnected($conn); 59 | } 60 | ); 61 | 62 | $handle->on_error( 63 | sub { 64 | $self->client_disconnected($conn); 65 | 66 | $handle->close; 67 | } 68 | ); 69 | 70 | $conn->on_write( 71 | sub { 72 | my $conn = shift; 73 | my ($message) = @_; 74 | 75 | $message = $self->_build_frame($message); 76 | 77 | $handle->write($message); 78 | } 79 | ); 80 | 81 | $conn->send_id_message($conn->id); 82 | 83 | $self->client_connected($conn); 84 | } 85 | ); 86 | }; 87 | } 88 | 89 | sub _build_frame { 90 | my $self = shift; 91 | my ($message) = @_; 92 | 93 | return Protocol::WebSocket::Frame->new($message)->to_string; 94 | } 95 | 96 | 1; 97 | __END__ 98 | 99 | =head1 NAME 100 | 101 | Plack::Middleware::SocketIO::WebSocket - WebSocket transport 102 | 103 | =head1 DESCRIPTION 104 | 105 | L is a WebSocket transport implementation. 106 | 107 | =head1 SEE ALSO 108 | 109 | L 110 | 111 | =cut 112 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/Resource.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::Resource; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Plack::Request; 7 | use Plack::Middleware::SocketIO::Connection; 8 | use Plack::Middleware::SocketIO::Handle; 9 | 10 | use Plack::Middleware::SocketIO::JSONPPolling; 11 | use Plack::Middleware::SocketIO::WebSocket; 12 | use Plack::Middleware::SocketIO::XHRMultipart; 13 | use Plack::Middleware::SocketIO::XHRPolling; 14 | use Plack::Middleware::SocketIO::Htmlfile; 15 | 16 | sub instance { 17 | my $class = shift; 18 | 19 | no strict; 20 | 21 | ${"$class\::_instance"} ||= $class->_new_instance(@_); 22 | 23 | return ${"$class\::_instance"}; 24 | } 25 | 26 | sub connection { 27 | my $self = shift; 28 | my ($id) = @_; 29 | 30 | return $self->{connections}->{$id}; 31 | } 32 | 33 | sub connections { 34 | my $self = shift; 35 | 36 | return values %{$self->{connections}}; 37 | } 38 | 39 | sub add_connection { 40 | my $self = shift; 41 | 42 | my $conn = $self->_build_connection(@_); 43 | 44 | $self->{connections}->{$conn->id} = $conn; 45 | 46 | return $conn; 47 | } 48 | 49 | sub remove_connection { 50 | my $self = shift; 51 | my ($id) = @_; 52 | 53 | delete $self->{connections}->{$id}; 54 | } 55 | 56 | sub finalize { 57 | my $self = shift; 58 | my ($env, $cb) = @_; 59 | 60 | my ($resource, $type) = $env->{PATH_INFO} =~ m{^/([^\/]+)/([^\/]+)/?}; 61 | return unless $resource && $type; 62 | 63 | my $transport = 64 | $self->_build_transport($type, env => $env, resource => $resource); 65 | return unless $transport; 66 | 67 | return $transport->finalize($cb); 68 | } 69 | 70 | sub _new_instance { 71 | my $class = shift; 72 | 73 | my $self = bless {@_}, $class; 74 | 75 | $self->{connections} = {}; 76 | 77 | return $self; 78 | } 79 | 80 | sub _build_transport { 81 | my $self = shift; 82 | my ($type, @args) = @_; 83 | 84 | my $class; 85 | if ($type eq 'xhr-multipart') { 86 | $class = 'XHRMultipart'; 87 | } 88 | elsif ($type eq 'xhr-polling') { 89 | $class = 'XHRPolling'; 90 | } 91 | elsif ($type eq 'jsonp-polling') { 92 | $class = 'JSONPPolling'; 93 | } 94 | elsif ($type =~ m/^(?:flash|web)socket$/) { 95 | $class = 'WebSocket'; 96 | } 97 | elsif ($type =~ m/^htmlfile$/) { 98 | $class = 'Htmlfile'; 99 | } 100 | 101 | return unless $class; 102 | 103 | $class = "Plack::Middleware::SocketIO::$class"; 104 | 105 | return $class->new(@args); 106 | } 107 | 108 | sub _build_connection { 109 | my $self = shift; 110 | 111 | return Plack::Middleware::SocketIO::Connection->new(@_); 112 | } 113 | 114 | 1; 115 | __END__ 116 | 117 | =head1 NAME 118 | 119 | Plack::Middleware::SocketIO::Resource - Resource class 120 | 121 | =head1 DESCRIPTION 122 | 123 | L is a singleton connection pool. 124 | 125 | =head1 METHODS 126 | 127 | =head2 C 128 | 129 | =head2 C 130 | 131 | =head2 C 132 | 133 | =head2 C 134 | 135 | =head2 C 136 | 137 | =cut 138 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/Handle.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::Handle; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent::Handle; 7 | 8 | sub new { 9 | my $class = shift; 10 | my ($fh) = @_; 11 | 12 | my $self = {handle => AnyEvent::Handle->new(fh => $fh)}; 13 | bless $self, $class; 14 | 15 | $fh->autoflush; 16 | 17 | $self->{handle}->no_delay(1); 18 | $self->{handle}->on_eof(sub { warn "Unhandled handle eof" }); 19 | $self->{handle}->on_error(sub { warn "Unhandled handle error: $_[2]" }); 20 | 21 | # This is needed for the correct EOF handling 22 | $self->{handle}->on_read(sub { }); 23 | 24 | return $self; 25 | } 26 | 27 | sub heartbeat_timeout { 28 | my $self = shift; 29 | my ($timeout) = @_; 30 | 31 | $self->{heartbeat_timeout} = $timeout; 32 | 33 | return $self; 34 | } 35 | 36 | sub on_heartbeat { 37 | my $self = shift; 38 | my ($cb) = @_; 39 | 40 | $self->{handle}->timeout($self->{heartbeat_timeout}); 41 | $self->{handle}->on_timeout($cb); 42 | 43 | return $self; 44 | } 45 | 46 | sub on_read { 47 | my $self = shift; 48 | my ($cb) = @_; 49 | 50 | $self->{handle}->on_read( 51 | sub { 52 | my $handle = shift; 53 | 54 | $handle->push_read( 55 | sub { 56 | $cb->($self, $_[0]->rbuf); 57 | } 58 | ); 59 | } 60 | ); 61 | 62 | return $self; 63 | } 64 | 65 | sub on_eof { 66 | my $self = shift; 67 | my ($cb) = @_; 68 | 69 | $self->{handle}->on_eof( 70 | sub { 71 | $cb->($self); 72 | } 73 | ); 74 | 75 | return $self; 76 | } 77 | 78 | sub on_error { 79 | my $self = shift; 80 | my ($cb) = @_; 81 | 82 | $self->{handle}->on_error( 83 | sub { 84 | $cb->($self); 85 | } 86 | ); 87 | 88 | return $self; 89 | } 90 | 91 | sub write { 92 | my $self = shift; 93 | my ($chunk, $cb) = @_; 94 | 95 | my $handle = $self->{handle}; 96 | return $self unless $handle; 97 | 98 | $handle->push_write($chunk); 99 | 100 | if ($cb) { 101 | $handle->on_drain( 102 | sub { 103 | $self->{handle}->on_drain(undef); 104 | 105 | $cb->($self); 106 | } 107 | ); 108 | } 109 | 110 | return $self; 111 | } 112 | 113 | sub close { 114 | my $self = shift; 115 | 116 | my $handle = delete $self->{handle}; 117 | return $self unless $handle; 118 | 119 | $handle->timeout_reset; 120 | 121 | shutdown $handle->fh, 2; 122 | close $handle->fh; 123 | 124 | $handle->destroy; 125 | undef $handle; 126 | 127 | return $self; 128 | } 129 | 130 | 1; 131 | __END__ 132 | 133 | =head1 NAME 134 | 135 | Plack::Middleware::SocketIO::Handle - Handle 136 | 137 | =head1 DESCRIPTION 138 | 139 | L is a wrapper on top of 140 | L. 141 | 142 | =head1 METHODS 143 | 144 | =head2 C 145 | 146 | =head2 C 147 | 148 | =head2 C 149 | 150 | =head2 C 151 | 152 | =head2 C 153 | 154 | =head2 C 155 | 156 | =head2 C 157 | 158 | =head1 SEE ALSO 159 | 160 | L 161 | 162 | =cut 163 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/Base.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use JSON (); 7 | use Encode (); 8 | use Try::Tiny; 9 | use Scalar::Util qw(weaken); 10 | 11 | use Plack::Request; 12 | use Plack::Middleware::SocketIO::Handle; 13 | use Plack::Middleware::SocketIO::Resource; 14 | 15 | sub new { 16 | my $class = shift; 17 | 18 | my $self = bless {@_}, $class; 19 | 20 | weaken $self->{env}; 21 | $self->{req} = Plack::Request->new($self->{env}); 22 | 23 | return $self; 24 | } 25 | 26 | sub req { shift->{req} } 27 | sub env { shift->{req}->{env} } 28 | 29 | sub resource { 30 | my $self = shift; 31 | my ($resource) = @_; 32 | 33 | return $self->{resource} unless defined $resource; 34 | 35 | $self->{resource} = $resource; 36 | 37 | return $self; 38 | } 39 | 40 | sub add_connection { 41 | my $self = shift; 42 | 43 | return Plack::Middleware::SocketIO::Resource->instance->add_connection( 44 | type => $self->name, 45 | @_ 46 | ); 47 | } 48 | 49 | sub remove_connection { 50 | my $self = shift; 51 | my ($conn) = @_; 52 | 53 | Plack::Middleware::SocketIO::Resource->instance->remove_connection( 54 | $conn->id); 55 | 56 | return $self; 57 | } 58 | 59 | sub find_connection_by_id { 60 | my $self = shift; 61 | my ($id) = @_; 62 | 63 | return Plack::Middleware::SocketIO::Resource->instance->connection($id); 64 | } 65 | 66 | sub client_connected { 67 | my $self = shift; 68 | my ($conn) = @_; 69 | 70 | return if $conn->is_connected; 71 | 72 | $self->_log_client_connected($conn); 73 | 74 | $conn->connect; 75 | } 76 | 77 | sub client_disconnected { 78 | my $self = shift; 79 | my ($conn) = @_; 80 | 81 | $conn->disconnect; 82 | 83 | $self->_log_client_disconnected($conn); 84 | 85 | $self->remove_connection($conn); 86 | } 87 | 88 | sub _log_client_connected { 89 | my $self = shift; 90 | my ($conn) = @_; 91 | 92 | my $logger = $self->_get_logger; 93 | return unless $logger; 94 | 95 | $logger->( 96 | { level => 'debug', 97 | message => sprintf( 98 | "Client '%s' connected via '%s'", 99 | $conn->id, $conn->type 100 | ) 101 | } 102 | ); 103 | } 104 | 105 | sub _log_client_disconnected { 106 | my $self = shift; 107 | my ($conn) = @_; 108 | 109 | my $logger = $self->_get_logger; 110 | return unless $logger; 111 | 112 | $logger->( 113 | { level => 'debug', 114 | message => sprintf("Client '%s' disconnected", $conn->id) 115 | } 116 | ); 117 | } 118 | 119 | sub _get_logger { 120 | my $self = shift; 121 | 122 | return $self->env->{'psgix.logger'}; 123 | } 124 | 125 | sub _build_handle { 126 | my $self = shift; 127 | 128 | return Plack::Middleware::SocketIO::Handle->new(@_); 129 | } 130 | 131 | 1; 132 | __END__ 133 | 134 | =head1 NAME 135 | 136 | Plack::Middleware::SocketIO::Base - Base class for transports 137 | 138 | =head1 DESCRIPTION 139 | 140 | L is a base class for the transports. 141 | 142 | =head1 METHODS 143 | 144 | =head2 C 145 | 146 | =head2 C 147 | 148 | =head2 C 149 | 150 | =head2 C 151 | 152 | =head2 C 153 | 154 | =head2 C 155 | 156 | =head2 C 157 | 158 | =head2 C 159 | 160 | =head2 C 161 | 162 | =cut 163 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/XHRPolling.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::XHRPolling; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::SocketIO::Base'; 7 | 8 | sub name {'xhr-polling'} 9 | 10 | sub finalize { 11 | my $self = shift; 12 | my ($cb) = @_; 13 | 14 | my $req = $self->req; 15 | my $resource = $self->resource; 16 | my $name = $self->name; 17 | 18 | if ($req->method eq 'GET') { 19 | return $self->_finalize_init($cb) 20 | if $req->path =~ m{^/$resource/$name//\d+$}; 21 | 22 | return $self->_finalize_stream($1) 23 | if $req->path =~ m{^/$resource/$name/(\d+)/\d+$}; 24 | } 25 | 26 | return 27 | unless $req->method eq 'POST' 28 | && $req->path_info =~ m{^/$resource/$name/(\d+)/send$}; 29 | 30 | return $self->_finalize_send($req, $1); 31 | } 32 | 33 | sub _finalize_init { 34 | my $self = shift; 35 | my ($cb) = @_; 36 | 37 | my $conn = $self->add_connection(on_connect => $cb); 38 | 39 | my $body = $conn->build_id_message; 40 | 41 | return [ 42 | 200, 43 | [ 'Content-Type' => 'text/plain', 44 | 'Content-Length' => length($body), 45 | 'Connection' => 'keep-alive' 46 | ], 47 | [$body] 48 | ]; 49 | } 50 | 51 | sub _finalize_stream { 52 | my $self = shift; 53 | my ($id) = @_; 54 | 55 | my $conn = $self->find_connection_by_id($id); 56 | return unless $conn; 57 | 58 | my $handle = $self->_build_handle($self->env->{'psgix.io'}); 59 | 60 | return sub { 61 | my $respond = shift; 62 | 63 | $handle->on_eof( 64 | sub { 65 | $self->client_disconnected($conn); 66 | 67 | $handle->close; 68 | } 69 | ); 70 | 71 | $handle->on_error( 72 | sub { 73 | $self->client_disconnected($conn); 74 | 75 | $handle->close; 76 | } 77 | ); 78 | 79 | $handle->heartbeat_timeout(10); 80 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 81 | 82 | $conn->on_write( 83 | sub { 84 | my $self = shift; 85 | my ($message) = @_; 86 | 87 | $handle->write( 88 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 89 | 'Content-Type: text/plain', 90 | 'Content-Length: ' . length($message), '', $message 91 | ); 92 | 93 | # TODO: set reconnect timeout 94 | 95 | $handle->close; 96 | } 97 | ); 98 | 99 | $self->client_connected($conn); 100 | }; 101 | } 102 | 103 | sub _finalize_send { 104 | my $self = shift; 105 | my ($req, $id) = @_; 106 | 107 | my $conn = $self->find_connection_by_id($id); 108 | return unless $conn; 109 | 110 | my $retval = [ 111 | 200, 112 | [ 'Content-Type' => 'text/plain', 113 | 'Transfer-Encoding' => 'chunked' 114 | ], 115 | ["2\x0d\x0aok\x0d\x0a" . "0\x0d\x0a\x0d\x0a"] 116 | ]; 117 | 118 | my $data = $req->body_parameters->get('data'); 119 | 120 | $conn->read($data); 121 | 122 | return $retval; 123 | } 124 | 125 | 1; 126 | __END__ 127 | 128 | =head1 NAME 129 | 130 | Plack::Middleware::SocketIO::XHRPolling - XHRPolling transport 131 | 132 | =head1 DESCRIPTION 133 | 134 | L is a C transport 135 | implementation. 136 | 137 | =head1 METHODS 138 | 139 | =head2 C 140 | 141 | =head2 C 142 | 143 | =cut 144 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/XHRMultipart.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::XHRMultipart; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::SocketIO::Base'; 7 | 8 | use Plack::Middleware::SocketIO::Handle; 9 | 10 | sub new { 11 | my $self = shift->SUPER::new(@_); 12 | 13 | $self->{boundary} ||= 'socketio'; 14 | 15 | return $self; 16 | } 17 | 18 | sub name {'xhr-multipart'} 19 | 20 | sub finalize { 21 | my $self = shift; 22 | my ($cb) = @_; 23 | 24 | my $req = $self->req; 25 | my $name = $self->name; 26 | my $resource = $self->resource; 27 | 28 | return $self->_finalize_stream($req, $cb) if $req->method eq 'GET'; 29 | 30 | return 31 | unless $req->method eq 'POST' 32 | && $req->path =~ m{^/$resource/$name/(\d+)/send$}; 33 | 34 | return $self->_finalize_send($req, $1); 35 | } 36 | 37 | sub _finalize_stream { 38 | my $self = shift; 39 | my ($req, $cb) = @_; 40 | 41 | my $handle = $self->_build_handle($req->env->{'psgix.io'}); 42 | return unless $handle; 43 | 44 | return sub { 45 | my $respond = shift; 46 | 47 | my $boundary = $self->{boundary}; 48 | 49 | my $conn = $self->add_connection(on_connect => $cb); 50 | 51 | $conn->on_write( 52 | sub { 53 | my $self = shift; 54 | my ($message) = @_; 55 | 56 | my $string = ''; 57 | 58 | $string .= "Content-Type: text/plain\x0a\x0a"; 59 | if ($message eq '') { 60 | $string .= "-1--$boundary--\x0a"; 61 | } 62 | else { 63 | $string .= "$message\x0a--$boundary\x0a"; 64 | } 65 | 66 | $handle->write($string); 67 | } 68 | ); 69 | 70 | $handle->heartbeat_timeout(10); 71 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 72 | 73 | $handle->on_eof( 74 | sub { 75 | my $handle = shift; 76 | 77 | $handle->close; 78 | 79 | $self->client_disconnected($conn); 80 | } 81 | ); 82 | 83 | $handle->on_error( 84 | sub { 85 | $self->client_disconnected($conn); 86 | 87 | $handle->close; 88 | } 89 | ); 90 | 91 | $handle->write( 92 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 93 | qq{Content-Type: multipart/x-mixed-replace;boundary="$boundary"}, 94 | 'Connection: keep-alive', '', '' 95 | ); 96 | 97 | $conn->send_id_message($conn->id); 98 | 99 | $self->client_connected($conn); 100 | }; 101 | } 102 | 103 | sub _finalize_send { 104 | my $self = shift; 105 | my ($req, $id) = @_; 106 | 107 | my $conn = $self->find_connection_by_id($id); 108 | return unless $conn; 109 | 110 | my $retval = [ 111 | 200, 112 | ['Content-Type' => 'text/plain', 'Transfer-Encoding' => 'chunked'], 113 | ["2\x0d\x0aok\x0d\x0a" . "0\x0d\x0a\x0d\x0a"] 114 | ]; 115 | 116 | my $data = $req->body_parameters->get('data'); 117 | 118 | $conn->read($data); 119 | 120 | return $retval; 121 | } 122 | 123 | 1; 124 | __END__ 125 | 126 | =head1 NAME 127 | 128 | Plack::Middleware::SocketIO::XHRMultipart - XHRMultipart transport 129 | 130 | =head1 DESCRIPTION 131 | 132 | L is a C transport 133 | implementation. 134 | 135 | =head1 METHODS 136 | 137 | =head2 C 138 | 139 | =head2 C 140 | 141 | =head2 C 142 | 143 | =cut 144 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/Htmlfile.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::Htmlfile; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::SocketIO::Base'; 7 | 8 | use HTTP::Body; 9 | 10 | sub name {'htmlfile'} 11 | 12 | sub finalize { 13 | my $self = shift; 14 | my ($cb) = @_; 15 | 16 | my $req = $self->req; 17 | my $resource = $self->resource; 18 | my $name = $self->name; 19 | 20 | if ($req->method eq 'GET') { 21 | return $self->_finalize_stream($cb) 22 | if $req->path =~ m{^/$resource/$name//\d+$}; 23 | } 24 | 25 | return 26 | unless $req->method eq 'POST' 27 | && $req->path_info =~ m{^/$resource/$name/(\d+)/send$}; 28 | 29 | return $self->_finalize_send($req, $1); 30 | } 31 | 32 | sub _finalize_stream { 33 | my $self = shift; 34 | my ($cb) = @_; 35 | 36 | my $handle = $self->_build_handle($self->env->{'psgix.io'}); 37 | 38 | return sub { 39 | my $conn = $self->add_connection(on_connect => $cb); 40 | 41 | $handle->on_eof( 42 | sub { 43 | $self->client_disconnected($conn); 44 | 45 | $handle->close; 46 | } 47 | ); 48 | 49 | $handle->on_error( 50 | sub { 51 | $self->client_disconnected($conn); 52 | 53 | $handle->close; 54 | } 55 | ); 56 | 57 | $handle->heartbeat_timeout(10); 58 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 59 | 60 | my $id = $self->_wrap_into_script($conn->build_id_message); 61 | 62 | $handle->write( 63 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 64 | 'Content-Type: text/html', 65 | 'Connection: keep-alive', 66 | 'Transfer-Encoding: chunked', 67 | '', 68 | sprintf('%x', 244 + 12), 69 | '' . (' ' x 244), 70 | sprintf('%x', length($id)), 71 | $id, 72 | '' 73 | ); 74 | 75 | $conn->on_write( 76 | sub { 77 | my $conn = shift; 78 | my ($message) = @_; 79 | 80 | $message = $self->_wrap_into_script($message); 81 | 82 | $handle->write( 83 | join "\x0d\x0a" => sprintf('%x', length($message)), 84 | $message, 85 | '' 86 | ); 87 | } 88 | ); 89 | 90 | $self->client_connected($conn); 91 | }; 92 | } 93 | 94 | sub _finalize_send { 95 | my $self = shift; 96 | my ($req, $id) = @_; 97 | 98 | my $conn = $self->find_connection_by_id($id); 99 | return unless $conn; 100 | 101 | my $retval = [ 102 | 200, 103 | [ 'Content-Type' => 'text/plain', 104 | 'Transfer-Encoding' => 'chunked' 105 | ], 106 | ["2\x0d\x0aok\x0d\x0a" . "0\x0d\x0a\x0d\x0a"] 107 | ]; 108 | 109 | my $raw_body = $req->content; 110 | my $zeros = $raw_body =~ s/\0//g; 111 | 112 | my $body = HTTP::Body->new($self->env->{CONTENT_TYPE}, 113 | $self->env->{CONTENT_LENGTH} - $zeros); 114 | $body->add($raw_body); 115 | 116 | my $data = $body->param->{data}; 117 | 118 | $conn->read($data); 119 | 120 | return $retval; 121 | } 122 | 123 | sub _wrap_into_script { 124 | my $self = shift; 125 | my ($message) = @_; 126 | 127 | $message =~ s/"/\\"/g; 128 | return qq{}; 129 | } 130 | 131 | 1; 132 | __END__ 133 | 134 | =head1 NAME 135 | 136 | Plack::Middleware::SocketIO::Htmlfile - Htmlfile transport 137 | 138 | =head1 DESCRIPTION 139 | 140 | L is a C transport 141 | implementation. 142 | 143 | =cut 144 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/JSONPPolling.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::JSONPPolling; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::SocketIO::Base'; 7 | 8 | sub name {'jsonp-polling'} 9 | 10 | sub finalize { 11 | my $self = shift; 12 | my ($cb) = @_; 13 | 14 | my $req = $self->req; 15 | my $name = $self->name; 16 | my $resource = $self->resource; 17 | 18 | if ($req->method eq 'GET') { 19 | return $self->_finalize_init($cb) 20 | if $req->path =~ m{^/$resource/$name//\d+/\d+$}; 21 | 22 | return $self->_finalize_stream($1) 23 | if $req->path =~ m{^/$resource/$name/(\d+)/\d+/\d+$}; 24 | } 25 | 26 | return 27 | unless $req->method eq 'POST' 28 | && $req->path =~ m{^/$resource/$name/(\d+)/\d+/\d+$}; 29 | 30 | return $self->_finalize_send($req, $1); 31 | } 32 | 33 | sub _finalize_init { 34 | my $self = shift; 35 | my ($cb) = @_; 36 | 37 | my $conn = $self->add_connection(on_connect => $cb); 38 | 39 | my $body = $self->_wrap_into_jsonp($conn->build_id_message); 40 | 41 | return [ 42 | 200, 43 | [ 'Content-Type' => 'text/plain', 44 | 'Content-Length' => length($body), 45 | 'Connection' => 'keep-alive' 46 | ], 47 | [$body] 48 | ]; 49 | } 50 | 51 | sub _finalize_stream { 52 | my $self = shift; 53 | my ($id) = @_; 54 | 55 | my $conn = $self->find_connection_by_id($id); 56 | return unless $conn; 57 | 58 | my $handle = $self->_build_handle($self->env->{'psgix.io'}); 59 | 60 | return sub { 61 | my $respond = shift; 62 | 63 | $handle->on_eof( 64 | sub { 65 | $self->client_disconnected($conn); 66 | 67 | $handle->close; 68 | } 69 | ); 70 | 71 | $handle->on_error( 72 | sub { 73 | $self->client_disconnected($conn); 74 | 75 | $handle->close; 76 | } 77 | ); 78 | 79 | $handle->heartbeat_timeout(10); 80 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 81 | 82 | $conn->on_write( 83 | sub { 84 | my $conn = shift; 85 | my ($message) = @_; 86 | 87 | $message = $self->_wrap_into_jsonp($message); 88 | 89 | $handle->write( 90 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 91 | 'Content-Type: text/plain', 92 | 'Content-Length: ' . length($message), '', $message 93 | ); 94 | 95 | # TODO: reconnect timeout 96 | 97 | $handle->close; 98 | } 99 | ); 100 | 101 | $self->client_connected($conn); 102 | }; 103 | } 104 | 105 | sub _finalize_send { 106 | my $self = shift; 107 | my ($req, $id) = @_; 108 | 109 | my $conn = $self->find_connection_by_id($id); 110 | return unless $conn; 111 | 112 | my $retval = [ 113 | 200, 114 | [ 'Content-Type' => 'text/plain', 115 | 'Transfer-Encoding' => 'chunked' 116 | ], 117 | ["2\x0d\x0aok\x0d\x0a" . "0\x0d\x0a\x0d\x0a"] 118 | ]; 119 | 120 | my $data = $req->body_parameters->get('data'); 121 | 122 | $conn->read($data); 123 | 124 | return $retval; 125 | } 126 | 127 | sub _wrap_into_jsonp { 128 | my $self = shift; 129 | my ($message) = @_; 130 | 131 | $message =~ s/"/\\"/g; 132 | return qq{io.JSONP[0]._("$message");}; 133 | } 134 | 135 | 1; 136 | __END__ 137 | 138 | =head1 NAME 139 | 140 | Plack::Middleware::SocketIO::JSONPPolling - JSONPPolling transport 141 | 142 | =head1 DESCRIPTION 143 | 144 | L is a C transport 145 | implementation. 146 | 147 | =head1 METHODS 148 | 149 | =head2 C 150 | 151 | =head2 C 152 | 153 | =cut 154 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware'; 7 | 8 | our $VERSION = '0.00904'; 9 | 10 | use Plack::Util (); 11 | use Plack::Util::Accessor qw(resource handler class instance method); 12 | 13 | use Plack::Middleware::SocketIO::Resource; 14 | 15 | sub new { 16 | my $self = shift->SUPER::new(@_); 17 | 18 | $self->handler($self->_get_handler); 19 | 20 | return $self; 21 | } 22 | 23 | sub call { 24 | my $self = shift; 25 | my ($env) = @_; 26 | 27 | my $resource = $self->resource || 'socket.io'; 28 | $resource = quotemeta $resource; 29 | 30 | if (defined $env->{PATH_INFO} && $env->{PATH_INFO} =~ m{^/$resource/}) { 31 | my $instance = Plack::Middleware::SocketIO::Resource->instance; 32 | 33 | return $instance->finalize($env, $self->handler) 34 | || [400, ['Content-Type' => 'text/plain'], ['Bad request']]; 35 | } 36 | 37 | return $self->app->($env); 38 | } 39 | 40 | sub _get_handler { 41 | my $self = shift; 42 | 43 | return $self->handler if $self->handler; 44 | 45 | die q{Either 'handler', 'class' or 'instance' must be specified} 46 | unless $self->instance || $self->class; 47 | 48 | my $method = $self->method || 'run'; 49 | 50 | my $instance = $self->instance 51 | || do { Plack::Util::load_class($self->class); $self->class->new; }; 52 | 53 | return $instance->run; 54 | } 55 | 56 | 1; 57 | __END__ 58 | 59 | =head1 NAME 60 | 61 | Plack::Middleware::SocketIO - Socket.IO middleware DEPRECATED 62 | 63 | =head1 SYNOPSIS 64 | 65 | use Plack::Builder; 66 | 67 | builder { 68 | enable "SocketIO", handler => sub { 69 | my $self = shift; 70 | 71 | $self->on_message( 72 | sub { 73 | my $self = shift; 74 | my ($message) = @_; 75 | 76 | ... 77 | } 78 | ); 79 | 80 | $self->send_message({buffer => []}); 81 | }; 82 | 83 | $app; 84 | }; 85 | 86 | # or 87 | 88 | builder { 89 | enable "SocketIO", class => 'MyApp::Handler', method => 'run'; 90 | 91 | $app; 92 | }; 93 | 94 | =head1 DESCRIPTION 95 | 96 | DEPRECATED. Use PocketIO instead L. 97 | 98 | L is a server implmentation of SocketIO in Perl. 99 | 100 | =head2 SocketIO 101 | 102 | More information about SocketIO you can find on the website L, or 103 | on the GitHub L. 104 | 105 | =head2 Transports 106 | 107 | All the transports are supported. 108 | 109 | WebSocket 110 | Adobe(R) Flash(R) Socket 111 | AJAX long polling 112 | AJAX multipart streaming 113 | Forever Iframe 114 | JSONP Polling 115 | 116 | =head2 TLS/SSL 117 | 118 | For TLS/SSL a secure proxy is needed. C or L is 119 | recommended. 120 | 121 | =head1 CONFIGURATIONS 122 | 123 | =over 4 124 | 125 | =item resource 126 | 127 | enable "SocketIO", 128 | resource => 'socket.io', ...; 129 | 130 | Specifies the path prefix under which all the requests are handled. This is done 131 | so the rest of your application won't interfere with Socket.IO specific calls. 132 | 133 | =item handler 134 | 135 | enable "SocketIO", 136 | handler => sub { 137 | my $socket = shift; 138 | 139 | $socket->on_message(sub { 140 | my $socket = shift; 141 | }); 142 | 143 | $socket->send_message('hello'); 144 | }; 145 | 146 | =item class or instance, method 147 | 148 | enable "SocketIO", 149 | class => 'MyHandler', method => 'run'; 150 | 151 | # or 152 | 153 | enable "SocketIO", 154 | instance => MyHandler->new(foo => 'bar'), method => 'run'; 155 | 156 | package MyHandler; 157 | 158 | sub new { ... } # or use Moose, Boose, Goose, Doose 159 | 160 | sub run { 161 | my $self = shift; 162 | 163 | return sub { 164 | 165 | # same code as above 166 | } 167 | } 168 | 169 | Loads C using L, creates a new object or uses 170 | a passed C and runs C method expecting it to return an anonymous 171 | subroutine. 172 | 173 | =back 174 | 175 | =head1 DEVELOPMENT 176 | 177 | =head2 Repository 178 | 179 | http://github.com/vti/plack-middleware-socketio 180 | 181 | =head1 CREDITS 182 | 183 | Socket.IO author(s) and contributors. 184 | 185 | =head1 AUTHOR 186 | 187 | Viacheslav Tykhanovskyi, C. 188 | 189 | =head1 COPYRIGHT AND LICENSE 190 | 191 | Copyright (C) 2011, Viacheslav Tykhanovskyi 192 | 193 | This program is free software, you can redistribute it and/or modify it under 194 | the terms of the Artistic License version 2.0. 195 | 196 | =cut 197 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/SocketIO/Connection.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::SocketIO::Connection; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use JSON (); 7 | use Try::Tiny; 8 | 9 | sub new { 10 | my $class = shift; 11 | 12 | my $self = {@_}; 13 | bless $self, $class; 14 | 15 | $self->{on_connect} ||= sub { }; 16 | $self->{on_message} ||= sub { }; 17 | $self->{on_disconnect} ||= sub { }; 18 | $self->{on_error} ||= sub { }; 19 | 20 | $self->{data} = ''; 21 | $self->{on_write} ||= sub { }; 22 | 23 | $self->{last_activity} = 0; 24 | 25 | return $self; 26 | } 27 | 28 | sub is_connected { 29 | my $self = shift; 30 | 31 | return $self->{is_connected}; 32 | } 33 | 34 | sub connect { 35 | my $self = shift; 36 | 37 | $self->{is_connected} = 1; 38 | 39 | $self->{on_connect}->($self); 40 | 41 | $self->{last_activity} = time; 42 | 43 | return $self; 44 | } 45 | 46 | sub disconnect { 47 | my $self = shift; 48 | 49 | $self->{is_connected} = 0; 50 | 51 | $self->{on_disconnect}->($self); 52 | 53 | return $self; 54 | } 55 | 56 | sub id { 57 | my $self = shift; 58 | 59 | $self->{id} ||= $self->_generate_id; 60 | 61 | return $self->{id}; 62 | } 63 | 64 | sub type { 65 | my $self = shift; 66 | my ($type) = @_; 67 | 68 | return $self->{type} unless defined $type; 69 | 70 | $self->{type} = $type; 71 | 72 | return $self; 73 | } 74 | 75 | sub on_message { shift->on(message => @_) } 76 | sub on_disconnect { shift->on(disconnect => @_) } 77 | sub on_error { shift->on(error => @_) } 78 | sub on_write { shift->on(write => @_) } 79 | 80 | sub on { 81 | my $self = shift; 82 | my ($event, $cb) = @_; 83 | 84 | my $name = "on_$event"; 85 | 86 | return $self->{$name} unless $cb; 87 | 88 | $self->{$name} = $cb; 89 | 90 | return $self; 91 | } 92 | 93 | sub read { 94 | my $self = shift; 95 | my ($data) = @_; 96 | 97 | return $self unless defined $data; 98 | 99 | $self->{last_activity} = time; 100 | 101 | $self->{data} .= $data; 102 | 103 | while (my $message = $self->_parse_data) { 104 | $self->on_message->($self, $message); 105 | } 106 | 107 | return $self; 108 | } 109 | 110 | sub send_heartbeat { 111 | my $self = shift; 112 | 113 | $self->{heartbeat}++; 114 | 115 | return $self->send_message('~h~' . $self->{heartbeat}); 116 | } 117 | 118 | sub send_message { 119 | my $self = shift; 120 | my ($message) = @_; 121 | 122 | $self->{last_activity} = time; 123 | 124 | $message = $self->_build_message($message); 125 | 126 | $self->on_write->($self, $message); 127 | 128 | return $self; 129 | } 130 | 131 | sub send_broadcast { 132 | my $self = shift; 133 | my ($message) = @_; 134 | 135 | my @conn = grep { $_->is_connected && $_->id ne $self->id } 136 | Plack::Middleware::SocketIO::Resource->instance->connections; 137 | 138 | foreach my $conn (@conn) { 139 | $conn->send_message($message); 140 | } 141 | 142 | return $self; 143 | } 144 | 145 | sub send_id_message { 146 | my $self = shift; 147 | 148 | $self->{last_activity} = time; 149 | 150 | my $message = $self->build_id_message; 151 | 152 | $self->on_write->($self, $message); 153 | 154 | return $self; 155 | } 156 | 157 | sub build_id_message { 158 | my $self = shift; 159 | 160 | return $self->_build_message($self->id); 161 | } 162 | 163 | sub _build_message { 164 | my $self = shift; 165 | my ($message) = @_; 166 | 167 | if (ref $message) { 168 | $message = '~j~' . JSON::encode_json($message); 169 | } 170 | 171 | return '~m~' . length($message) . '~m~' . $message; 172 | } 173 | 174 | sub _generate_id { 175 | my $self = shift; 176 | 177 | my $string = ''; 178 | 179 | for (1 .. 16) { 180 | $string .= int(rand(10)); 181 | } 182 | 183 | return $string; 184 | } 185 | 186 | sub _parse_data { 187 | my $self = shift; 188 | 189 | if ($self->{data} =~ s/^~m~(\d+)~m~//) { 190 | my $length = $1; 191 | 192 | my $message = substr($self->{data}, 0, $length, ''); 193 | if (length($message) == $length) { 194 | if ($message =~ m/^~h~(\d+)/) { 195 | my $heartbeat = $1; 196 | 197 | return $self->_parse_data; 198 | } 199 | elsif ($message =~ m/^~j~(.*)/) { 200 | my $json; 201 | 202 | try { 203 | $json = JSON::decode_json($1); 204 | }; 205 | 206 | return $json if defined $json; 207 | 208 | return $self->_parse_data; 209 | } 210 | else { 211 | return $message; 212 | } 213 | } 214 | } 215 | 216 | $self->{data} = ''; 217 | return; 218 | } 219 | 220 | 1; 221 | __END__ 222 | 223 | =head1 NAME 224 | 225 | Plack::Middleware::SocketIO::Connection - Connection class 226 | 227 | =head1 DESCRIPTION 228 | 229 | L is a connection class that 230 | incapsulates all the logic for bulding and parsing Socket.IO messages. 231 | 232 | =head1 METHODS 233 | 234 | =head2 C 235 | 236 | =head2 C 237 | 238 | =head2 C 239 | 240 | =head2 C 241 | 242 | =head2 C 243 | 244 | =head2 C 245 | 246 | =head2 C 247 | 248 | =head2 C 249 | 250 | =head2 C 251 | 252 | =head2 C 253 | 254 | =head2 C 255 | 256 | =head1 INTERNAL METHODS 257 | 258 | =head2 C 259 | 260 | =head2 C 261 | 262 | =head2 C 263 | 264 | =head2 C 265 | 266 | =head2 C 267 | 268 | =head2 C 269 | 270 | =cut 271 | --------------------------------------------------------------------------------