File Coverage

blib/lib/Tak/ConnectorService.pm
Criterion Covered Total %
statement 30 62 48.3
branch 0 22 0.0
condition 0 5 0.0
subroutine 10 14 71.4
pod 0 3 0.0
total 40 106 37.7


line stmt bran cond sub pod time code
1             package Tak::ConnectorService;
2              
3 1     1   1627 use IPC::Open2;
  1         211  
  1         46  
4 1     1   747 use IO::Socket::UNIX;
  1         15953  
  1         6  
5 1     1   622 use IO::Socket::INET; # Sucks to be v6, see comment where used
  1         2  
  1         7  
6 1     1   1066 use IO::All;
  1         1  
  1         21  
7 1     1   609 use Tak::Router;
  1         4  
  1         26  
8 1     1   7 use Tak::Client;
  1         1  
  1         21  
9 1     1   6 use Tak::ConnectionService;
  1         1  
  1         23  
10 1     1   1636 use Net::OpenSSH;
  1         24151  
  1         71  
11 1     1   3109 use Tak::STDIONode;
  1         4  
  1         36  
12 1     1   7 use Moo;
  1         4  
  1         54  
13              
14             with 'Tak::Role::Service';
15              
16             has connections => (is => 'ro', default => sub { Tak::Router->new });
17              
18             has ssh => (is => 'ro', default => sub { {} });
19              
20             sub handle_create {
21 0     0 0   my ($self, $on, %args) = @_;
22 0 0         die [ mistake => "No target supplied to create" ] unless $on;
23 0   0       my $log_level = $args{log_level}||'info';
24 0           my ($kid_in, $kid_out, $kid_pid) = $self->_open($on, $log_level);
25 0 0         if ($kid_pid) {
26 0 0         $kid_in->print($Tak::STDIONode::DATA, "__END__\n") unless $on eq '-';
27             # Need to get a handshake to indicate STDIOSetup has finished
28             # messing around with file descriptors, otherwise we can severely
29             # confuse things by sending before the dup.
30 0           my $up = <$kid_out>;
31 0 0         die [ failure => "Garbled response from child: $up" ]
32             unless $up eq "Shere\n";
33             }
34 0           my $connection = Tak::ConnectionService->new(
35             read_fh => $kid_out, write_fh => $kid_in,
36             listening_service => Tak::Router->new
37             );
38 0           my $client = Tak::Client->new(service => $connection);
39             # actually, we should register with a monotonic id and
40             # stash the pid elsewhere. but meh for now.
41 0           my $pid = $client->do(meta => 'pid');
42 0           my $name = $on.':'.$pid;
43 0           my $conn_router = Tak::Router->new;
44 0           $conn_router->register(local => $connection->receiver->service);
45 0           $conn_router->register(remote => $connection);
46 0           $self->connections->register($name, $conn_router);
47 0           return ($name);
48             }
49              
50             sub _open {
51 0     0     my ($self, $on, @args) = @_;
52 0 0         if ($on eq '-') {
    0          
    0          
53 0 0         my $kid_pid = IPC::Open2::open2(my $kid_out, my $kid_in, 'tak-stdio-node', '-', @args)
54             or die "Couldn't open2 child: $!";
55 0           return ($kid_in, $kid_out, $kid_pid);
56             } elsif ($on =~ /^\.?\//) { # ./foo or /foo
57 0 0         my $sock = IO::Socket::UNIX->new($on)
58             or die "Couldn't open unix domain socket ${on}: $!";
59 0           return ($sock, $sock, undef);
60             } elsif ($on =~ /:/) { # foo:80 we hope
61             # IO::Socket::IP is a better answer. But can pull in XS deps.
62             # Well, more strictly it pulls in Socket::GetAddrInfo, which can
63             # actually work without its XS implementation (just doesn't handle v6)
64             # and I've not properly pondered how to make things like fatpacking
65             # Just Fucking Work in such a circumstance. First person to need IPv6
66             # and be reading this comment, please start a conversation about it.
67 0 0         my $sock = IO::Socket::INET->new(PeerAddr => $on)
68             or die "Couldn't open TCP socket ${on}: $!";
69 0           return ($sock, $sock, undef);
70             }
71 0   0       my $ssh = $self->ssh->{$on} ||= Net::OpenSSH->new($on);
72 0 0         $ssh->error and
73             die "Couldn't establish ssh connection: ".$ssh->error;
74 0           return $ssh->open2('perl','-', $on, @args);
75             }
76              
77             sub start_connection_request {
78 0     0 0   my ($self, $req, @payload) = @_;;
79 0           $self->connections->start_request($req, @payload);
80             }
81              
82             sub receive_connection {
83 0     0 0   my ($self, @payload) = @_;
84 0           $self->connections->receive(@payload);
85             }
86              
87             1;