File Coverage

blib/lib/GuacLite/Plugin/Guacd.pm
Criterion Covered Total %
statement 24 39 61.5
branch 1 6 16.6
condition n/a
subroutine 5 9 55.5
pod 1 1 100.0
total 31 55 56.3


line stmt bran cond sub pod time code
1             package GuacLite::Plugin::Guacd;
2              
3 1     1   28244 use Mojo::Base 'Mojolicious::Plugin';
  1         2  
  1         6  
4              
5             sub register {
6 1     1 1 40 my ($plugin, $app, $conf) = @_;
7 1         6 $app->helper('guacd.tunnel' => \&_tunnel);
8             }
9              
10             sub _tunnel {
11 1     1   17712 my ($c, $client) = @_;
12              
13 1         4 my $tx = $c->tx;
14 1         8 $tx->with_protocols('guacamole');
15 1         57 $tx->with_compression;
16 1         28 $tx->max_websocket_size(10485760);
17              
18 1     0   12 $c->on(finish => sub { $client->close; undef $c; undef $tx; undef $client });
  0         0  
  0         0  
  0         0  
  0         0  
19 1     0   248 $client->on(close => sub { $c->finish });
  0         0  
20              
21             return $client->connect_p
22 1     1   706 ->then(sub { $client->handshake_p })
23             ->then(sub {
24 1     1   263 my $id = shift;
25              
26 1         6 my $ws_stream = Mojo::IOLoop->stream($c->tx->connection);
27 1         35 my $guacd_stream = $client->stream;
28              
29             $client->on(instruction => sub {
30 0         0 $c->send({text => $_[1]});
31              
32 0 0       0 return if $ws_stream->can_write;
33 0         0 _backpressure($guacd_stream => $ws_stream);
34 1         8 });
35             $c->on(text => sub {
36 1         2923 my (undef, $bytes) = @_;
37              
38             # OOB messages are sent with empty instruction, for now assume its a ping
39 1 50       8 if(substr($bytes, 0, 2) eq '0.') {
40 1         5 return $c->send({text => $bytes});
41             }
42              
43 0         0 $client->write($bytes);
44              
45 0 0       0 return if $guacd_stream->can_write;
46 0         0 _backpressure($ws_stream => $guacd_stream);
47 1         39 });
48             # initiate by sending the id, except the frontend doesn't want the $
49 1         33 $id =~ s/^\$//;
50 1         6 $c->send({text => GuacLite::Client::Guacd::encode(['', $id])});
51 1         12 });
52             }
53              
54             # handle backpressure, but it assumes there already is some don't call unles
55             # you've checked can_write, that said, don't put it in here for efficiency's sake
56             sub _backpressure {
57 0     0     my ($in, $out) = @_;
58 0           $in->stop;
59 0     0     $out->once(drain => sub { $in->start });
  0            
60             }
61              
62             1;
63