| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package AnyEvent::WebSocket::Server; | 
| 2 | 9 |  |  | 9 |  | 1024766 | use strict; | 
|  | 9 |  |  |  |  | 20 |  | 
|  | 9 |  |  |  |  | 365 |  | 
| 3 | 9 |  |  | 9 |  | 48 | use warnings; | 
|  | 9 |  |  |  |  | 15 |  | 
|  | 9 |  |  |  |  | 327 |  | 
| 4 | 9 |  |  | 9 |  | 49 | use Carp; | 
|  | 9 |  |  |  |  | 20 |  | 
|  | 9 |  |  |  |  | 791 |  | 
| 5 | 9 |  |  | 9 |  | 8016 | use AnyEvent::Handle; | 
|  | 9 |  |  |  |  | 126475 |  | 
|  | 9 |  |  |  |  | 426 |  | 
| 6 | 9 |  |  | 9 |  | 6832 | use Protocol::WebSocket::Handshake::Server; | 
|  | 9 |  |  |  |  | 1576071 |  | 
|  | 9 |  |  |  |  | 433 |  | 
| 7 | 9 |  |  | 9 |  | 111 | use Try::Tiny; | 
|  | 9 |  |  |  |  | 19 |  | 
|  | 9 |  |  |  |  | 858 |  | 
| 8 | 9 |  |  | 9 |  | 7200 | use AnyEvent::WebSocket::Connection; | 
|  | 9 |  |  |  |  | 87670 |  | 
|  | 9 |  |  |  |  | 9146 |  | 
| 9 |  |  |  |  |  |  |  | 
| 10 |  |  |  |  |  |  | our $VERSION = "0.09"; | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  | sub new { | 
| 13 | 54 |  |  | 54 | 1 | 918885 | my ($class, %args) = @_; | 
| 14 | 54 |  |  |  |  | 171 | my $validator = $args{validator}; | 
| 15 | 54 | 50 | 66 |  |  | 337 | if(defined($validator) && ref($validator) ne "CODE") { | 
| 16 | 0 |  |  |  |  | 0 | croak "validator parameter must be a code-ref"; | 
| 17 |  |  |  |  |  |  | } | 
| 18 |  |  |  |  |  |  | my $handshake = defined($args{handshake}) ? $args{handshake} | 
| 19 | 9 |  |  | 9 |  | 75 | : defined($validator) ? sub { my ($req, $res) = @_; return ($res, $validator->($req)); } | 
|  | 9 |  |  |  |  | 51 |  | 
| 20 | 54 | 100 |  | 168 |  | 1764 | : sub { $_[1] }; | 
|  | 168 | 100 |  |  |  | 1246 |  | 
| 21 | 54 | 50 |  |  |  | 290 | if(ref($handshake) ne "CODE") { | 
| 22 | 0 |  |  |  |  | 0 | croak "handshake parameter must be a code-ref"; | 
| 23 |  |  |  |  |  |  | } | 
| 24 |  |  |  |  |  |  | my $self = bless { | 
| 25 |  |  |  |  |  |  | handshake => $handshake, | 
| 26 | 54 |  |  |  |  | 144 | map { ($_ => $args{$_}) } qw(ssl_key_file ssl_cert_file max_payload_size), | 
|  | 162 |  |  |  |  | 601 |  | 
| 27 |  |  |  |  |  |  | }, $class; | 
| 28 | 54 |  |  |  |  | 266 | return $self; | 
| 29 |  |  |  |  |  |  | } | 
| 30 |  |  |  |  |  |  |  | 
| 31 |  |  |  |  |  |  | sub _create_on_error { | 
| 32 | 212 |  |  | 212 |  | 441 | my ($cv) = @_; | 
| 33 |  |  |  |  |  |  | return sub { | 
| 34 | 4 |  |  | 4 |  | 611 | my ($handle, $fatal, $message) = @_; | 
| 35 | 4 | 50 |  |  |  | 17 | if($fatal) { | 
| 36 | 4 |  |  |  |  | 31 | $cv->croak("connection error: $message"); | 
| 37 |  |  |  |  |  |  | }else { | 
| 38 | 0 |  |  |  |  | 0 | warn $message; | 
| 39 |  |  |  |  |  |  | } | 
| 40 | 212 |  |  |  |  | 2117 | }; | 
| 41 |  |  |  |  |  |  | } | 
| 42 |  |  |  |  |  |  |  | 
| 43 |  |  |  |  |  |  | sub _handle_args_tls { | 
| 44 | 212 |  |  | 212 |  | 334 | my ($self) = @_; | 
| 45 | 212 | 100 | 66 |  |  | 1154 | if(!defined($self->{ssl_key_file}) && !defined($self->{ssl_cert_file})) { | 
| 46 | 71 |  |  |  |  | 231 | return (); | 
| 47 |  |  |  |  |  |  | } | 
| 48 | 141 | 50 |  |  |  | 561 | if(!defined($self->{ssl_cert_file})) { | 
| 49 | 0 |  |  |  |  | 0 | croak "Only ssl_key_file is specified. You need to specify ssl_cert_file, too."; | 
| 50 |  |  |  |  |  |  | } | 
| 51 |  |  |  |  |  |  | return ( | 
| 52 |  |  |  |  |  |  | tls => "accept", | 
| 53 |  |  |  |  |  |  | tls_ctx => { | 
| 54 |  |  |  |  |  |  | cert_file => $self->{ssl_cert_file}, | 
| 55 | 141 | 100 |  |  |  | 1448 | defined($self->{ssl_key_file}) ? (key_file => $self->{ssl_key_file}) : () | 
| 56 |  |  |  |  |  |  | } | 
| 57 |  |  |  |  |  |  | ); | 
| 58 |  |  |  |  |  |  | } | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | sub _do_handshake { | 
| 61 | 212 |  |  | 212 |  | 434 | my ($self, $cv_connection, $fh, $handshake) = @_; | 
| 62 | 212 |  |  |  |  | 541 | my $handshake_code = $self->{handshake}; | 
| 63 | 212 |  |  |  |  | 723 | my $handle = AnyEvent::Handle->new( | 
| 64 |  |  |  |  |  |  | $self->_handle_args_tls, | 
| 65 |  |  |  |  |  |  | fh => $fh, on_error => _create_on_error($cv_connection) | 
| 66 |  |  |  |  |  |  | ); | 
| 67 |  |  |  |  |  |  | my $read_cb = sub { | 
| 68 |  |  |  |  |  |  | ## We don't receive handle object as an argument here. $handle | 
| 69 |  |  |  |  |  |  | ## is imported in this closure so that $handle becomes | 
| 70 |  |  |  |  |  |  | ## half-immortal. | 
| 71 |  |  |  |  |  |  | try { | 
| 72 | 423 | 100 |  |  |  | 23340 | if(!defined($handshake->parse($handle->{rbuf}))) { | 
| 73 | 4 |  |  |  |  | 1198 | die "handshake error: " . $handshake->error . "\n"; | 
| 74 |  |  |  |  |  |  | } | 
| 75 | 419 | 100 |  |  |  | 176152 | return if !$handshake->is_done; | 
| 76 | 204 | 50 |  |  |  | 2702 | if($handshake->version ne "draft-ietf-hybi-17") { | 
| 77 | 0 |  |  |  |  | 0 | die "handshake error: unsupported WebSocket protocol version " . $handshake->version . "\n"; | 
| 78 |  |  |  |  |  |  | } | 
| 79 | 204 |  |  |  |  | 2179 | my ($res, @other_results) = $handshake_code->($handshake->req, $handshake->res); | 
| 80 | 195 | 100 |  |  |  | 5571 | if(!defined($res)) { | 
| 81 | 3 |  |  |  |  | 594 | croak "handshake response was undef"; | 
| 82 |  |  |  |  |  |  | } | 
| 83 | 192 | 100 |  |  |  | 661 | if(ref($res) eq "Protocol::WebSocket::Response") { | 
| 84 | 189 |  |  |  |  | 778 | $res = $res->to_string; | 
| 85 |  |  |  |  |  |  | } | 
| 86 | 192 |  |  |  |  | 72117 | $handle->push_write("$res"); | 
| 87 |  |  |  |  |  |  | $cv_connection->send( | 
| 88 | 192 |  |  |  |  | 29255 | AnyEvent::WebSocket::Connection->new(handle => $handle, max_payload_size => $self->{max_payload_size}), | 
| 89 |  |  |  |  |  |  | @other_results | 
| 90 |  |  |  |  |  |  | ); | 
| 91 | 192 |  |  |  |  | 121863 | undef $handle; | 
| 92 | 192 |  |  |  |  | 905 | undef $cv_connection; | 
| 93 |  |  |  |  |  |  | }catch { | 
| 94 | 16 |  |  |  |  | 760 | my $e = shift; | 
| 95 | 16 |  |  |  |  | 331 | $cv_connection->croak($e); | 
| 96 | 16 |  |  |  |  | 14127 | undef $handle; | 
| 97 | 16 |  |  |  |  | 83 | undef $cv_connection; | 
| 98 | 423 |  |  | 423 |  | 4302054 | }; | 
| 99 | 212 |  |  |  |  | 150299 | }; | 
| 100 | 212 |  |  |  |  | 594 | $handle->{rbuf} = ""; | 
| 101 | 212 |  |  |  |  | 729 | $read_cb->();  ## in case the whole request is already consumed | 
| 102 | 212 | 50 |  |  |  | 7850 | $handle->on_read($read_cb) if defined $handle; | 
| 103 |  |  |  |  |  |  | } | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | sub establish { | 
| 106 | 213 |  |  | 213 | 1 | 714186 | my ($self, $fh) = @_; | 
| 107 | 213 |  |  |  |  | 8037 | my $cv_connection = AnyEvent->condvar; | 
| 108 | 213 | 100 |  |  |  | 2469 | if(!defined($fh)) { | 
| 109 | 1 |  |  |  |  | 13 | $cv_connection->croak("fh parameter is mandatory for establish() method"); | 
| 110 | 1 |  |  |  |  | 79 | return $cv_connection; | 
| 111 |  |  |  |  |  |  | } | 
| 112 | 212 |  |  |  |  | 2859 | my $handshake = Protocol::WebSocket::Handshake::Server->new; | 
| 113 | 212 |  |  |  |  | 2116 | $self->_do_handshake($cv_connection, $fh, $handshake); | 
| 114 | 212 |  |  |  |  | 8123 | return $cv_connection; | 
| 115 |  |  |  |  |  |  | } | 
| 116 |  |  |  |  |  |  |  | 
| 117 |  |  |  |  |  |  | sub establish_psgi { | 
| 118 | 0 |  |  | 0 | 1 |  | my ($self, $env, $fh) = @_; | 
| 119 | 0 |  |  |  |  |  | my $cv_connection = AnyEvent->condvar; | 
| 120 | 0 | 0 |  |  |  |  | if(!defined($env)) { | 
| 121 | 0 |  |  |  |  |  | $cv_connection->croak("psgi_env parameter is mandatory"); | 
| 122 | 0 |  |  |  |  |  | return $cv_connection; | 
| 123 |  |  |  |  |  |  | } | 
| 124 | 0 | 0 |  |  |  |  | $fh = $env->{"psgix.io"} if not defined $fh; | 
| 125 | 0 | 0 |  |  |  |  | if(!defined($fh)) { | 
| 126 | 0 |  |  |  |  |  | $cv_connection->croak("No connection file handle provided. Maybe the PSGI server does not support psgix.io extension."); | 
| 127 | 0 |  |  |  |  |  | return $cv_connection; | 
| 128 |  |  |  |  |  |  | } | 
| 129 | 0 |  |  |  |  |  | my $handshake = Protocol::WebSocket::Handshake::Server->new_from_psgi($env); | 
| 130 | 0 |  |  |  |  |  | $self->_do_handshake($cv_connection, $fh, $handshake); | 
| 131 | 0 |  |  |  |  |  | return $cv_connection; | 
| 132 |  |  |  |  |  |  | } | 
| 133 |  |  |  |  |  |  |  | 
| 134 |  |  |  |  |  |  | 1; | 
| 135 |  |  |  |  |  |  |  | 
| 136 |  |  |  |  |  |  | __END__ |