File Coverage

blib/lib/Terse/WebSocket.pm
Criterion Covered Total %
statement 6 139 4.3
branch 0 78 0.0
condition 0 36 0.0
subroutine 2 7 28.5
pod 1 5 20.0
total 9 265 3.4


line stmt bran cond sub pod time code
1             package Terse::WebSocket;
2              
3 13     13   127 use base 'Terse';
  13         30  
  13         1483  
4 13     13   6206 use MIME::Base64;
  13         8341  
  13         23221  
5              
6             sub new {
7 0     0 1   my ($class, $t) = @_;
8 0           my $self = $class->SUPER::new();
9 0           my $version = '';
10 0           my $env = $t->request->env;
11 0 0 0       if (!$env->{$t->{_sock}} || !$env->{$t->{_stream_check}}) {
12 0           return 'Invalid environment no _sock or _stream_check in env';
13             }
14             $self->options = {
15             secret => $t->{_app_secret} || 'ABABCABC-ABC-ABC-ABCD-ABCABCABCABC',
16             upgrade => $env->{HTTP_UPGRADE},
17             connection => $env->{HTTP_CONNECTION},
18             host => $env->{HTTP_HOST},
19             origin => $env->{HTTP_ORIGIN},
20             ($env->{HTTP_SEC_WEBSOCKET_KEY}
21             ? (sec_websocket_key => $env->{HTTP_SEC_WEBSOCKET_KEY})
22             : ()
23             ),
24             ($env->{HTTP_SEC_WEBSOCKET_KEY1}
25             ? (sec_websocket_key1 => $env->{HTTP_SEC_WEBSOCKET_KEY1})
26             : (sec_websocket_key2 => $env->{HTTP_SEC_WEBSOCKET_KEY2})
27 0 0 0       ),
    0          
28             subprotocol => 'chat',
29             };
30 0 0         if (exists $env->{HTTP_SEC_WEBSOCKET_VERSION}) {
31 0           $fields->{'sec_websocket_version'} = $env->{HTTP_SEC_WEBSOCKET_VERSION};
32 0 0         if ($env->{HTTP_SEC_WEBSOCKET_VERSION} eq '13') {
33 0           $self->version = 'draft-ietf-hybi-17';
34             }
35             else {
36 0           $self->version = 'draft-ietf-hybi-10';
37             }
38             }
39             $self->resource_name = "$env->{SCRIPT_NAME}$env->{PATH_INFO}"
40 0 0         . ($env->{QUERY_STRING} ? "?$env->{QUERY_STRING}" : "");
41 0           $self->psgix = $env->{'psgix.io'};
42 0 0 0       if ($env->{HTTP_X_FORWARDED_PROTO} && $env->{HTTP_X_FORWARDED_PROTO} eq 'https') {
43 0           $self->secure(1);
44             }
45 0 0         unless ($self->parse($_[0])) {
46 0           $self->error($req->error);
47 0           return;
48             }
49 0           return $self;
50             }
51              
52             sub start {
53 0     0 0   my ($self, $t, $cbs, $responder) = @_;
54 0           my $writer = eval { $responder->([101, [$self->headers]]); };
  0            
55 0 0         $cbs->{($@ ? 'error' : 'connect')}->($self, $responder, $@);
56 0   0       my $reset_rate = $t->websocket_reset_rate ||= 100000;
57 0           eval {
58 0           my $ping_rate = $reset_rate;
59 0           while (1) {
60 0           $ping_rate--;
61 0           my $response;
62 0 0         if ($ping_rate < 0) {
63 0           $ping_rate = $reset_rate;
64 0           $self->send($ping);
65 0   0       $response = $self->recieve() while($ping_rate-- > 0 && !$response);
66 0 0 0       if (!$response || $response ne 'pong') {
67 0           last;
68             }
69 0           $ping_rate = $reset_rate;
70             }
71 0           $response = $self->recieve();
72 0 0         if ($response) {
73 0 0         if ($response =~ m/^invalid_(length|version|host|required_key)$/) {
74 0           $cbs->{error}->($self, $response, $responder);
75 0           last;
76             } else {
77 0           $ping_rate = $reset_rate;
78 0           $cbs->{recieve}->($self, $response, $responder);
79             }
80             }
81             }
82             };
83 0 0         $cbs->{error}->($self, $responder, $@) if ($@);
84 0 0         $cbs->{disconnect}->($self, $responder) if $cbs->{disconnect};
85 0 0         delete $t->{_application}->websockets->{$t->sid->value} if $cbs->{close_delete};
86 0           $responder->([200, []]);
87             }
88              
89             sub headers {
90 0     0 0   my ($self) = @_;
91 0   0       my $version = $self->version || 'draft-ietf-hybi-10';
92 0           my @headers = ();
93 0           push @headers, Upgrade => 'WebSocket';
94 0           push @headers, Connection => 'Upgrade';
95 0 0 0       if ($version eq 'draft-hixie-75' || $version eq 'draft-ietf-hybi-00') {
    0 0        
96 0 0         return 'invalid_host' unless defined $self->options->host;
97 0           my $location = 'ws';
98 0 0         $location .= 's' if $self->options->secure;
99 0           $location .= '://';
100 0           $location .= $self->options->host;
101 0 0         $location .= ':' . $self->options->port if defined $self->options->port;
102 0   0       $location .= $self->resource_name || '/';
103 0 0         my $origin = $self->options->origin ? $self->options->origin : 'http://' . $self->options->host;
104 0 0 0       $origin =~ s{^http:}{https:} if !$self->options->origin && $self->options->secure;
105 0 0         if ($version eq 'draft-hixie-75') {
    0          
106 0 0         push @headers, 'WebSocket-Protocol' => $self->subprotocol
107             if defined $self->options->subprotocol;
108 0           push @headers, 'WebSocket-Origin' => $origin;
109 0           push @headers, 'WebSocket-Location' => $location;
110             }
111             elsif ($version eq 'draft-ietf-hybi-00') {
112 0 0         push @headers, 'Sec-WebSocket-Protocol' => $self->options->subprotocol
113             if defined $self->options->subprotocol;
114 0           push @headers, 'Sec-WebSocket-Origin' => $origin;
115 0           push @headers, 'Sec-WebSocket-Location' => $location;
116             }
117             }
118             elsif ($version eq 'draft-ietf-hybi-10' || $version eq 'draft-ietf-hybi-17') {
119 0 0         return 'invalid_required_key' unless defined $self->options->key;
120 0           my $key = $self->options->key;
121 0           $key .= $self->options->secret;
122 0           $key = Digest::SHA::sha1($key);
123 0           $key = MIME::Base64::encode_base64($key);
124 0           $key =~ s{\s+}{}g;
125 0           push @headers, 'Sec-WebSocket-Accept' => $key;
126 0 0         push @headers, 'Sec-WebSocket-Protocol' => $self->options->subprotocol
127             if defined $self->options->subprotocol;
128             }
129             else {
130 0           return 'invalid_version';
131             }
132 0           return @headers;
133             }
134              
135             sub send {
136 0     0 0   my ($self, $message) = @_;
137 0           my $pg = $self->psgix;
138 0   0       my $mask = $self->mask ||= 0;
139 0           my (@ENCODED) = map { ord($_) } split //, $message;
  0            
140 0           my $length = scalar @ENCODED + 128;
141 0 0 0       if ($length > 254 || $mask) {
142 0           @MASK = map { int(rand(256)) } 0 .. 3;
  0            
143 0           my $i;
144 0           $ENCODED[$i++] = $_ ^ $MASK[$i % 4] for (@ENCODED);
145 0           unshift @ENCODED, @MASK;
146 0 0         if ($length > 256) {
147 0           my $times = int(($length + 2) / 254) - 1;
148 0           my $excess = $length - (($times * 256) + 128);
149 0           unshift @ENCODED, (254, $times, $excess);
150             } else {
151 0           unshift @ENCODED, $length;
152             }
153             } else {
154 0           unshift @ENCODED, $length - 128;
155             }
156 0           syswrite $pg, join("", map {chr($_)} (129, @ENCODED));
  0            
157 0           return $self;
158             }
159              
160             sub recieve {
161 0     0 0   my ($self, @ENCODED) = @_;
162 0           my $length;
163 0 0         if (! scalar @ENCODED ) {
164 0 0 0       return shift @{ $self->next_frame } if scalar @{ $self->next_frame ||= [] };
  0            
  0            
165 0           my $pg = $self->psgix;
166 0           my $content = "";
167 0           $length = sysread($pg, $content, 8192);
168 0 0         return unless $length;
169 0           $length = sysread($pg, $content, 8192, length($content)) while $length >= 8192;
170 0           @ENCODED = map { unpack "C", $_ } split //, $content;
  0            
171             }
172 0           my @bits = split //, sprintf("%b\n", $ENCODED[0]);
173 0           $self->fin = $bits[0];
174 0           $self->rsv = [@bits[1 .. 3]];
175 0           $self->op = shift @ENCODED;
176 0 0         if ($ENCODED[0] == 254) {
177 0           my @length = splice @ENCODED, 0, 3;
178 0           $length = ((($length[0] + 2) * $length[1]) + $length[2]);
179             } else {
180 0           $length = shift @ENCODED;
181 0           $length -= 128;
182             }
183 0 0         return pack "C*", join("", @ENCODED) if (scalar @ENCODED == $length);
184 0           my @MASK = splice @ENCODED, 0, 4;
185 0 0         if (scalar @ENCODED > $length) {
186 0           my $next = $self->recieve(splice @ENCODED, $length, scalar @ENCODED);
187 0 0         return $next if ($next eq 'invalid_length');
188 0           unshift @{ $self->next_frame }, $next;
  0            
189             }
190 0 0         return 'invalid_length' if (scalar @ENCODED != $length);
191 0           return join "", map { pack "C", ($ENCODED[$_] ^ $MASK[$_ % 4]) } 0 .. $#ENCODED;
  0            
192             }
193              
194             1;
195              
196             __END__;