File Coverage

blib/lib/Net/SIP/SocketPool.pm
Criterion Covered Total %
statement 249 340 73.2
branch 123 248 49.6
condition 30 69 43.4
subroutine 25 29 86.2
pod 4 4 100.0
total 431 690 62.4


line stmt bran cond sub pod time code
1             # Collection of sockets associated with a Leg:
2             # This gets attached to an IO-Loop so that a common callback will be called with
3             # (packet,from) which then can be processed by the Leg and Dispatcher.
4             # Sending through the SocketPool is done by automatically selecting or creating
5             # the appropriate socket based on target and/or packet->tid.
6              
7 41     41   446 use strict;
  41         98  
  41         1350  
8 41     41   229 use warnings;
  41         80  
  41         1852  
9             package Net::SIP::SocketPool;
10 41     41   231 use fields qw(loop ipproto tls dst fds tids cb timeout_timer);
  41         85  
  41         294  
11              
12 41     41   4867 use Net::SIP::Util ':all';
  41         111  
  41         7861  
13 41     41   20745 use Net::SIP::Packet;
  41         124  
  41         1440  
14 41     41   323 use Net::SIP::Debug;
  41         93  
  41         205  
15 41     41   19841 use Net::SIP::Dispatcher::Eventloop;
  41         115  
  41         2241  
16 41     41   268 use Socket qw(SOL_SOCKET SO_ERROR);
  41         87  
  41         201247  
17              
18             # RFC does not specify some fixed limit for the SIP header and body so we have
19             # to make up some limits we think are useful.
20             my $MAX_SIP_HEADER = 2**14; # 16k header
21             my $MAX_SIP_BODY = 2**16; # 64k body
22              
23             # how many requests we can associate with a socket at the same time
24             my $MAX_TIDLIST = 30;
25              
26             my $MIN_EXPIRE = 15; # wait at least this time before closing on inactivity
27             my $MAX_EXPIRE = 120; # wait at most this time
28             my $CONNECT_TIMEOUT = 10; # max time for TCP connect
29             my $TCP_READSIZE = 2**16; # size of TCP read
30              
31             sub import {
32 41     41   277 my %m = (
33             MAX_SIP_HEADER => \$MAX_SIP_HEADER,
34             MAX_SIP_BODY => \$MAX_SIP_BODY,
35             MAX_TIDLIST => \$MAX_TIDLIST,
36             MIN_EXPIRE => \$MIN_EXPIRE,
37             MAX_EXPIRE => \$MAX_EXPIRE,
38             CONNECT_TIMEOUT => \$CONNECT_TIMEOUT,
39             TCP_READSIZE => \$TCP_READSIZE,
40             );
41 41         1409 for(my $i=1;$i<@_;$i+=2) {
42 0 0       0 my $ref = $m{$_[$i]} or die "no such config key '$_[$i]'";
43 0         0 $$ref = $_[$i+1];
44             }
45             }
46              
47             my %TLSClientDefault = (SSL_verifycn_scheme => 'sip');
48             my %TLSServerDefault = ();
49              
50             # will be defined on first use of SSL depending if IO::Socket::SSL is available
51             my $CAN_TLS;
52             my $SSL_REUSE_CTX;
53             my ($SSL_WANT_READ, $SSL_WANT_WRITE, $SSL_VERIFY_PEER,
54             $SSL_VERIFY_FAIL_IF_NO_PEER_CERT);
55             our $SSL_ERROR;
56              
57              
58             ###########################################################################
59             # create a new SocketPool
60             # Args: ($class,$proto,$fd,$peer,$connected,$tls)
61             # $proto: udp|tcp|tls
62             # $fd: the file descriptor for the master socket (i.e. listener)
63             # $peer: optional hash with addr,port,family of destination if restricted
64             # $connected: true if $fd is connected to $peer (useful with UDP only)
65             # $tls: \%options for IO::Socket::SSL when proto is tls
66             # Returns: $self
67             ###########################################################################
68             sub new {
69 141     141 1 681 my ($class,$proto,$fd,$peer,$connected,$tls) = @_;
70 141         678 my $self = fields::new($class);
71 141 100       15648 if ($proto eq 'tls') {
72             # the underlying proto is still TCP and we remember to use TLS by
73             # having a true self.tls
74 38         396 $self->{ipproto} = 'tcp';
75 38   50 13   4342 $CAN_TLS //= eval "use IO::Socket::SSL;1" && eval {
  13   66     553  
  13         191  
  13         572  
76             # 1.956 defines the 'sip' scheme for hostname validation
77             IO::Socket::SSL->VERSION >= 1.956
78             or die "need at least version 1.956";
79             $SSL_WANT_READ = IO::Socket::SSL::SSL_WANT_READ();
80             $SSL_WANT_WRITE = IO::Socket::SSL::SSL_WANT_WRITE();
81             $SSL_VERIFY_PEER = IO::Socket::SSL::SSL_VERIFY_PEER();
82             $SSL_VERIFY_FAIL_IF_NO_PEER_CERT =
83             IO::Socket::SSL::SSL_VERIFY_FAIL_IF_NO_PEER_CERT();
84             *SSL_ERROR = \$IO::Socket::SSL::SSL_ERROR;
85             # 1.969 fixed name validation when reusing context
86             $SSL_REUSE_CTX = IO::Socket::SSL->VERSION >= 1.969;
87             1;
88             } || die "no SSL support using IO::Socket::SSL: $@";
89              
90             # create different contexts for [m]aster and [c]lient
91 38   50     197 $tls ||= {};
92 38         153 my $verify_client = delete $tls->{verify_client};
93 38         661 $self->{tls}{c} = { %TLSClientDefault, %$tls };
94             $self->{tls}{m} = {
95 38 0       558 %TLSServerDefault,
    0          
    50          
96             %$tls,
97             SSL_server => 1,
98             # request client certificate?
99             ! $verify_client ? ():
100             $verify_client == -1 ? (SSL_verify_mode => $SSL_VERIFY_PEER) :
101             $verify_client == 1 ? (SSL_verify_mode =>
102             $SSL_VERIFY_PEER|$SSL_VERIFY_FAIL_IF_NO_PEER_CERT) :
103             die "invalid setting for SSL_verify_client: $verify_client"
104             };
105 38 50       212 if ($SSL_REUSE_CTX) {
106 38         135 for(qw(m c)) {
107 76 50       369 $self->{tls}{$_}{SSL_reuse_ctx} and next;
108 76   50     851 my $ctx = IO::Socket::SSL::SSL_Context->new($self->{tls}{$_})
109             || die "failed to create SSL context: $SSL_ERROR";
110 76         83676 $self->{tls}{$_}{SSL_reuse_ctx} = $ctx;
111             }
112             }
113             } else {
114 103   50     535 $self->{ipproto} = $proto || die "no protocol given";
115             }
116              
117 141         470 $self->{fds} = {};
118 141         384 $self->{tids} = {};
119 141 50       471 if (!$connected) {
120 141         309 $self->{dst} = $peer;
121 141         296 $peer = undef;
122             }
123 141 50       2233 _add_socket($self,{
124             fd => $fd,
125             $peer ? (peer => $peer) : (),
126             master => 1,
127             });
128 141         708 return $self;
129             }
130              
131             sub DESTROY {
132 134     134   28410879 my Net::SIP::SocketPool $self = shift;
133             # detach from current loop
134 134 50       11490 if ($self->{loop}) {
135 0         0 for(values %{$self->{fds}}) {
  0         0  
136 0   0     0 $self->{loop}->delFD($_->{fd} || next);
137             }
138             }
139             }
140              
141             ###########################################################################
142             # attaches SocketPool to EventLoop
143             # Args: ($self,$loop,$callback)
144             # $loop: Net::SIP::Dispatcher::Eventloop or API compatible
145             # $callback: should be called for each new SIP packet received
146             # Comment:
147             # If $loop is empty it just detaches from the current loop
148             ###########################################################################
149             sub attach_eventloop {
150 108     108 1 257 my Net::SIP::SocketPool $self = shift;
151 108         307 my ($loop,$cb) = @_;
152 108 100       387 if ($self->{loop}) {
153 51         110 for(values %{$self->{fds}}) {
  51         270  
154 74         345 $self->{loop}->delFD($_->{fd});
155             }
156 51 100       221 if ($self->{timeout_timer}) {
157 25         121 $self->{timeout_timer}->cancel;
158 25         66 undef $self->{timeout_timer};
159             }
160             }
161 108 100       891 if ($self->{loop} = $loop) {
162 57         135 $self->{cb} = $cb;
163 57         141 _addreader2loop($self,$_) for values %{$self->{fds}};
  57         1115  
164             }
165             }
166              
167             ###########################################################################
168             # returns master socket
169             # Args: $self
170             # Returns: $fd
171             # $fd: master socket
172             ###########################################################################
173             sub master {
174 0     0 1 0 my Net::SIP::SocketPool $self = shift;
175 0         0 my @fo = grep { $_->{master} } values %{$self->{fds}};
  0         0  
  0         0  
176 0 0       0 die "no master" if ! @fo;
177 0 0       0 die "multiple master" if @fo>1;
178 0         0 return $fo[0]{fd};
179             }
180              
181             ###########################################################################
182             # send packet via SocketPool
183             # Args: ($self,$packet,$dst,$callback)
184             # $packet: Net::SIP::Packet
185             # $dst: where to send as hash with addr,port,family
186             # $callback: callback to call on definite successful delivery (TCP/TLS only)
187             # or on error
188             ###########################################################################
189             sub sendto {
190 188     188 1 397 my Net::SIP::SocketPool $self = shift;
191 188         493 my ($packet,$dst,$callback) = @_;
192 188 50       892 if ($self->{dst}) {
    50          
193 0         0 $dst = $self->{dst}; # override destination
194             } elsif (!ref($dst)) {
195 0         0 $dst = ip_string2parts($dst);
196             }
197              
198             # select all sockets which are connected to the target
199             # if we have multiple connected reduce further by packets tid
200             # take one socket
201              
202 188         363 my $fos = [ values %{$self->{fds}} ];
  188         777  
203 188 100       708 if (@$fos>1) {
204 67         176 my $match = 0;
205             # any socket associated with tid?
206 67 100 66     210 if ($packet->is_response and my $fo = $self->{tids}{$packet->tid}) {
207 37 50       119 if (my @s = grep { $_ == $fo } @$fos) {
  74         300  
208 37         91 $match |= 1;
209 37         128 $fos = \@s
210             }
211             }
212 67 100       295 if (@$fos>1) {
213             # any socket connected to dst?
214 30 50       111 if ( my @s = grep {
215             $_->{peer} &&
216             $_->{peer}{addr} eq $dst->{addr} &&
217             $_->{peer}{port} == $dst->{port}
218 60 100 66     704 } @$fos) {
219 30         102 $match |= 2;
220 30         89 $fos = \@s;
221             }
222             }
223 67 50       211 if (!$match) {
224             # use master
225 0         0 $fos = [ grep { $_->{master} } @$fos ];
  0         0  
226             }
227             }
228              
229 188         483 my $fo = $fos->[0];
230 188         828 my $data = $packet->as_string;
231 188 100       859 if ($self->{ipproto} eq 'udp') {
232 106 50       344 if ($fo->{peer}) {
233             # send over connected UDP socket
234 0         0 my $rv = send($fo->{fd},$data,0);
235 0 0       0 invoke_callback($callback, $!) if ! defined($rv);
236 0         0 return;
237             } else {
238             # sendto over unconnected UDP socket
239 106         573 my $rv = send($fo->{fd},$data,0, ip_parts2sockaddr($dst));
240 106 50       723 invoke_callback($callback, $!) if ! defined($rv);
241 106         635 return;
242             }
243             }
244              
245 82 50       532 if ($self->{ipproto} eq 'tcp') {
246 82 100       562 if ($fo->{peer}) {
247             $DEBUG && DEBUG(40,"send tcp data to %s via %s",
248             ip_parts2string($dst),
249 67 50       197 ip_parts2string($fo->{peer}));
250             # send over this connected socket
251 67         350 $fo->{wbuf} .= $data;
252 67 50       497 _tcp_send($self,$fo,$callback) if ! $fo->{inside_connect};
253 67         399 return;
254             }
255              
256             # TCP listener: we need to create a new connected socket first
257 15 50       81 $DEBUG && DEBUG(40,"need new tcp socket to %s",
258             ip_parts2string($dst));
259             my $clfd = INETSOCK(
260             Proto => 'tcp',
261             Reuse => 1, ReuseAddr => 1,
262 15         424 LocalAddr => (ip_sockaddr2parts(getsockname($fo->{fd})))[0],
263             Blocking => 0,
264             );
265             $fo = $self->_add_socket({
266             fd => $clfd,
267             peer => $dst,
268             rbuf => '',
269             wbuf => $data,
270             didit => $self->{loop}->looptime,
271 15         8669 inside_connect => 1,
272             });
273 15         106 _tcp_connect($self,$fo,ip_parts2sockaddr($dst),$callback);
274 15         89 return;
275             }
276              
277 0         0 die "unknown type $self->{ipproto}";
278             }
279              
280              
281             sub _add_socket {
282 166     166   548 my Net::SIP::SocketPool $self = shift;
283 166         504 my $fo = shift;
284 166         2608 $fo->{fd}->blocking(0);
285 166         5354 $self->{fds}{ fileno($fo->{fd}) } = $fo;
286 166 100 100     1307 _addreader2loop($self,$fo) if $self->{loop} && ! $fo->{inside_connect};
287 166 100 66     1830 $self->_timeout_sockets if ! $self->{timeout_timer} && $fo->{didit};
288 166         431 return $fo;
289             }
290              
291             sub _del_socket {
292 2     2   5 my Net::SIP::SocketPool $self = shift;
293 2         5 my $fo = shift;
294 2 50       13 $self->_error(@_) if @_;
295 2 50       20 $self->{loop}->delFD($fo->{fd}) if $self->{loop};
296 2         8 delete $self->{fds}{ fileno($fo->{fd}) };
297 2 50       20 if ($fo->{tids}) {
298 2         6 delete $self->{tids}{$_} for @{$fo->{tids}};
  2         14  
299             }
300 2         139 return;
301             }
302              
303             sub _timeout_sockets {
304 30     30   128 my Net::SIP::SocketPool $self = shift;
305 30         178 my $fds = $self->{fds};
306 30 50       276 goto disable_timer if keys(%$fds) <= 1;
307 30 50       485 return if ! $self->{loop};
308              
309 30         229 DEBUG(99,"timeout sockets");
310              
311             # the more sockets we have open the faster expire
312 30         206 my $expire = $MIN_EXPIRE + ($MAX_EXPIRE - $MIN_EXPIRE)/(keys(%$fds)-1);
313 30         135 my ($time,$need_timer);
314 30         198 for (values %$fds) {
315 60   100     836 my $tdiff = -($_->{didit} || next) + ($time||= $self->{loop}->looptime);
      33        
316 30 50 66     536 if ($tdiff>$expire) {
    50          
317 0         0 $self->_del_socket($_);
318             } elsif ($_->{inside_connect} && $tdiff > $CONNECT_TIMEOUT) {
319 0         0 $self->_del_socket($_,"connect timed out");
320             } else {
321 30         102 $need_timer = 1;
322             }
323             }
324 30 50       151 if ($need_timer) {
325 30 100       206 return if $self->{timeout_timer};
326 25         194 DEBUG(99,"timeout sockets - need timer");
327             $self->{timeout_timer} = $self->{loop}->add_timer(
328 25         349 int($MIN_EXPIRE/2)+1,
329             [ \&_timeout_sockets, $self ],
330             int($MIN_EXPIRE/2)+1,
331             'socketpool-timeout'
332             );
333 25         83 return;
334             }
335             disable_timer:
336 0         0 DEBUG(99,"timer cancel");
337 0   0     0 ($self->{timeout_timer} || return)->cancel;
338 0         0 undef $self->{timeout_timer};
339             }
340              
341             sub _error {
342 0     0   0 my Net::SIP::SocketPool $self = shift;
343 0         0 my $msg = shift;
344 0 0       0 $msg = sprintf($msg,@_) if @_;
345 0         0 DEBUG(1,$msg);
346 0         0 return;
347             }
348              
349             {
350             my %type2cb = (
351             # unconnected UDP socket: receive and send
352             udp_m => sub {
353             my Net::SIP::SocketPool $self = shift;
354             return $self->{dst}
355             ? sub { _handle_read_udp(@_,1) }
356             : sub { _handle_read_udp(@_) }
357             },
358             # connected UDP socket: receive and send with fixed peer
359             udp_co => sub {
360             return \&_handle_read_udp
361             },
362             # unconnected TCP socket: listen, accept and create tcp_co
363             tcp_m => sub {
364             return \&_handle_read_tcp_m
365             },
366             # connected TCP socket: receive and send with fixed peer
367             tcp_co => sub {
368             my (undef,$fd) = @_;
369             my $from = getpeername($fd);
370             return sub { _handle_read_tcp_co(@_,$from) }
371             }
372             );
373             sub _addreader2loop {
374 82     82   239 my Net::SIP::SocketPool $self = shift;
375 82         165 my $fo = shift;
376             # proto_co: connected socket, proto_m: (unconnected) master socket
377 82 100       536 my $type = $self->{ipproto} . ($fo->{peer} ? '_co':'_m');
378             $self->{loop}->addFD($fo->{fd}, EV_READ, [
379 82         935 $type2cb{$type}($self,$fo->{fd}),
380             $self
381             ]);
382             }
383             }
384              
385             sub _check_from {
386 0     0   0 my Net::SIP::SocketPool $self = shift;
387 0 0       0 my $dst = $self->{dst} or return;
388 0         0 my ($ip,$port) = ip_sockaddr2parts(shift());
389 0 0 0     0 if ($ip ne $dst->{addr} or $port ne $dst->{port}) {
390 0 0       0 $DEBUG && DEBUG(1,
391             "drop packet received from %s since expecting only from %s",
392             ip_parts2string($ip,$port),
393             ip_parts2string($dst)
394             );
395 0         0 return 0;
396             }
397 0         0 return 1;
398             }
399              
400             sub _handle_read_udp {
401 118     118   254 my Net::SIP::SocketPool $self = shift;
402 118         235 my $fd = shift;
403 118 50       799 my $fo = $self->{fds}{ fileno($fd) } or die;
404 118 50       2613 my $from = recv($fd, my $buf, 2**16, 0) or return;
405              
406             # packet must be at least 13 bytes big (first line incl version
407             # + final crlf crlf). Ignore anything smaller, probably keep-alives
408 118 50       562 if ( length($buf)<13 ) {
409 0         0 DEBUG(11,"ignored packet with len ".length($buf)." because to small (keep-alive?)");
410 0         0 return;
411             }
412              
413             # check dst on unconnected UDP sockets
414 118 50 33     436 shift() && ! _check_from($self,$from) && return;
415              
416 118 50       298 my $pkt = eval { Net::SIP::Packet->new_from_string($buf) } or
  118         957  
417             return $self->_error(
418             "drop invalid packet received from %s: %s",
419             ip_sockaddr2string($from), $@
420             );
421              
422             invoke_callback($self->{cb},$pkt, {
423 118         373 %{ ip_sockaddr2parts($from) },
  118         535  
424             proto => 'udp',
425             socket => $fd,
426             });
427             }
428              
429             # read from unconnected TCP socket:
430             # - accept new connection
431             # - check against dst
432             # - setup new connection to receive data
433             sub _handle_read_tcp_m {
434 10     10   122 my Net::SIP::SocketPool $self = shift;
435 10         52 my $srvfd = shift;
436 10 50       217 my $srvfo = $self->{fds}{ fileno($srvfd) } or die;
437 10 50       1469 my $from = accept(my $clfd, $srvfd) or return;
438 10 50 33     331 $self->{dst} && ! _check_from($self,$from) && return;
439             my $clfo = $self->_add_socket({
440             fd => $clfd,
441             peer => scalar(ip_sockaddr2parts($from)),
442             rbuf => '',
443             wbuf => '',
444             didit => $self->{loop}->looptime,
445 10   100     143 inside_connect => $self->{tls} && 1,
446             });
447 10 100       125 _tls_accept($self,$clfo) if $self->{tls};
448             }
449              
450              
451             # read from connected TCP socket:
452             # Since TCP is a stream SIP messages might be split over multiple reads or
453             # a single read might contain more than one message.
454             sub _handle_read_tcp_co {
455 88     88   267 my Net::SIP::SocketPool $self = shift;
456 88         281 my ($fd,$from) = @_;
457 88 50       751 my $fo = $self->{fds}{ fileno($fd) } or die "no fd for read";
458              
459             $DEBUG && $fo->{rbuf} ne '' && DEBUG(20,
460 88 50 33     1214 "continue reading SIP packet, offset=%d",length($fo->{rbuf}));
461              
462             retry:
463             my $n = sysread($fd, $fo->{rbuf},
464             # read max size of TLS frame when tls so that we don't get any awkward
465             # effects with user space buffering in TLS stack and select(2)
466             $self->{tls} ? 2**14 : $TCP_READSIZE,
467 88 100       1759 length($fo->{rbuf}));
468 88 50       3930 if (!defined $n) {
469 0 0       0 goto retry if $!{EINTR};
470 0 0 0     0 return if $!{EAGAIN} || $!{EWOULDBLOCK};
471 0         0 return $self->_del_socket($fo,
472             "error while reading from %s: %s",
473             ip_sockaddr2string($from), $!);
474             }
475 88 100       831 if (!$n) {
476             # peer closed
477 2         31 return $self->_del_socket($fo);
478             }
479              
480             process_packet:
481             # ignore any leading \r\n according to RFC 3261 7.5
482 86 50       869 if ($fo->{rbuf} =~s{\A((?:\r\n)+)}{}) {
483 0 0       0 $DEBUG && DEBUG(20,"skipped over newlines preceding packet, size=%d",
484             length($1));
485             }
486              
487 86         465 my $hdrpos = index($fo->{rbuf},"\r\n\r\n");
488 86 50 33     905 if ($hdrpos<0 && length($fo->{rbuf}) > $MAX_SIP_HEADER
      33        
489             or $hdrpos > $MAX_SIP_HEADER) {
490 0         0 return $self->_del_socket($fo,
491             "drop packet from %s since SIP header is too big",
492             ip_sockaddr2string($from));
493             }
494 86 50       319 if ($hdrpos<0) {
495 0 0       0 $DEBUG && DEBUG(20,"need more data for SIP header");
496 0         0 return;
497             }
498 86         207 $hdrpos += 4; # after header
499 86         815 my %clen = map { $_ => 1 }
500 86         1757 substr($fo->{rbuf},0,$hdrpos) =~m{\n(?:l|Content-length):\s*(\d+)\s*\n}ig;
501 86 50       364 if (!%clen) {
502 0         0 return $self->_del_socket($fo,
503             "drop invalid SIP packet from %s: missing content-length",
504             ip_sockaddr2string($from));
505             }
506 86 50       390 if (keys(%clen)>1) {
507 0         0 return $self->_del_socket($fo,
508             "drop invalid SIP packet from %s: conflicting content-length",
509             ip_sockaddr2string($from));
510             }
511 86         383 my $clen = (keys %clen)[0];
512 86 50       365 if ($clen > $MAX_SIP_BODY) {
513 0         0 return $self->_del_socket($fo,
514             "drop packet from %s since SIP body is too big: %d>%d",
515             ip_sockaddr2string($from), $clen, $MAX_SIP_BODY);
516             }
517 86 50       432 if ($hdrpos + $clen > length($fo->{rbuf})) {
518             $DEBUG && DEBUG(20,"need %d more bytes for SIP body",
519 0 0       0 $hdrpos + $clen - length($fo->{rbuf}));
520 0         0 return;
521             }
522              
523 86 50       229 my $pkt = eval {
524 86         1314 Net::SIP::Packet->new_from_string(substr($fo->{rbuf},0,$hdrpos+$clen,''))
525             } or return $self->_del_socket($fo,
526             "drop invalid packet received from %s: %s",
527             ip_sockaddr2string($from), $@);
528              
529 86 100       764 if ($pkt->is_request) {
530             # associate $pkt->tid with this socket
531 30   100     321 my $tidlist = $fo->{tids} ||= [];
532 30         218 push @$tidlist, $pkt->tid;
533 30         164 while (@$tidlist > $MAX_TIDLIST) {
534 0         0 my $tid = shift(@$tidlist);
535 0         0 delete $self->{tids}{$tid};
536             }
537 30         202 $self->{tids}{ $tidlist->[-1] } = $fo;
538             }
539              
540 86 50       555 $fo->{didit} = $self->{loop}->looptime if $self->{loop};
541             invoke_callback($self->{cb},$pkt, {
542 86         412 %{ ip_sockaddr2parts($from) },
543 86 100       233 proto => $self->{tls} ? 'tls' : 'tcp',
544             socket => $fd,
545             });
546              
547             # continue with processing any remaining data in the buffer
548 86 50       1439 goto process_packet if $fo->{rbuf} ne '';
549             }
550              
551             sub _tcp_connect {
552 30     30   79 my Net::SIP::SocketPool $self = shift;
553 30         122 my ($fo,$peer,$callback,$xxfd) = @_;
554              
555 30         145 while (!$xxfd) {
556             # direct call, no connect done yet
557 15         117 $fo->{didit} = $self->{loop}->looptime;
558 15         2518 my $rv = connect($fo->{fd},$peer);
559 15 50 0     107 $DEBUG && DEBUG(100,"tcp connect: ".($rv || $!));
560 15 50       129 if ($rv) {
561             # successful connect
562 0 0       0 return _tls_connect($self,$fo,$callback) if $self->{tls};
563 0         0 delete $fo->{inside_connect};
564 0         0 last;
565             }
566 15 50       644 next if $!{EINTR};
567 15 50 33     471 if ($!{EALREADY} || $!{EINPROGRESS}) {
568             # insert write handler
569 15 50       724 $DEBUG && DEBUG(100,"tcp connect: add write handler for async connect");
570 15         142 $self->{loop}->addFD($fo->{fd}, EV_WRITE,
571             [ \&_tcp_connect, $self,$fo,$peer,$callback ]);
572 15         90 return;
573             }
574             # connect permanently failed
575 0         0 my $err = $!;
576 0         0 $self->_del_socket($fo,
577             "connect to ".ip_sockaddr2string($peer)." failed: $!");
578 0         0 invoke_callback($callback,$err);
579 0         0 return;
580             }
581              
582 15 50       105 if ($xxfd) {
583             # we are called from loop and hopefully async connect was succesful:
584             # use getsockopt to check
585 15         268 my $err = getsockopt($xxfd, SOL_SOCKET, SO_ERROR);
586 15 50       173 $err = $err ? unpack('i',$err) : $!;
587 15 50       90 if ($err) {
588             # connection failed
589 0         0 $! = $err;
590 0         0 $self->_del_socket($fo,
591             "connect to ".ip_sockaddr2string($peer)." failed: $!");
592 0         0 invoke_callback($callback,$err);
593 0         0 return;
594             }
595              
596             # connect done: remove write handler
597 15         123 $self->{loop}->delFD($xxfd, EV_WRITE);
598 15 100       123 return _tls_connect($self,$fo,$callback) if $self->{tls};
599 10         30 delete $fo->{inside_connect};
600             }
601              
602 10         46 _addreader2loop($self,$fo);
603            
604             # if we have something to write continue in _tcp_send
605 10 50       94 return _tcp_send($self,$fo,$callback) if $fo->{wbuf} ne '';
606              
607             # otherwise signal success via callback
608 0         0 invoke_callback($callback,0)
609             }
610              
611             sub _tcp_send {
612 82     82   201 my Net::SIP::SocketPool $self = shift;
613 82         270 my ($fo,$callback,$xxfd) = @_;
614 82         401 while ($fo->{wbuf} ne '') {
615 82         739 $fo->{didit} = $self->{loop}->looptime;
616 82 50       4832 if (my $n = syswrite($fo->{fd},$fo->{wbuf})) {
617 82         11043 substr($fo->{wbuf},0,$n,'');
618 82         363 next;
619             }
620              
621 0 0       0 next if $!{EINTR};
622 0 0 0     0 if ($!{EAGAIN} || $!{EWOULDBLOCK}) {
623 0 0       0 return if $xxfd; # called from loop: write handler already set up
624             # insert write handler
625 0         0 $self->{loop}->addFD($fo->{fd}, EV_WRITE,
626             [ \&_tcp_send, $self,$fo,$callback ]);
627 0         0 return;
628             }
629              
630             # permanently failed to write
631 0         0 my $err = $!;
632 0         0 $self->_del_socket($fo, "write failed: $!");
633 0         0 invoke_callback($callback,$err);
634 0         0 return;
635             }
636              
637             # write done: remove write handler if we are called from loop
638 82 50       282 $DEBUG && DEBUG(90,"everything has been sent");
639 82 50       247 $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd;
640              
641             # signal success via callback
642 82         488 invoke_callback($callback,0)
643             }
644              
645             sub _tls_accept {
646 15     15   44 my Net::SIP::SocketPool $self = shift;
647 15         35 my ($fo,$xxfd) = @_;
648 15 100       53 if (!$xxfd) {
649 5 50       41 $DEBUG && DEBUG(40,"upgrade to SSL server");
650             IO::Socket::SSL->start_SSL($fo->{fd},
651 5 50       46 %{$self->{tls}{m}},
  5         147  
652             SSL_startHandshake => 0,
653             ) or die "upgrade to SSL socket failed: $SSL_ERROR";
654             }
655              
656 15 100       1222 if ($fo->{fd}->accept_SSL()) {
657 5 50       2703 if ($DEBUG) {
658 0         0 my $peer_cert = $fo->{fd}->peer_certificate;
659 0 0       0 DEBUG(40,"TLS accept success, %s", $peer_cert
660             ? "peer="._dump_certificate($peer_cert)
661             : 'no peer certificate');
662             }
663 5         19 delete $fo->{inside_connect};
664 5 50       58 $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd;
665 5         30 _addreader2loop($self,$fo);
666 5         24 return;
667             }
668              
669 10 50       84551 if ($SSL_ERROR == $SSL_WANT_READ) {
    0          
670 10 50       49 $DEBUG && DEBUG(40,"TLS accept - want read");
671 10 100       86 $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd;
672 10         76 $self->{loop}->addFD($fo->{fd}, EV_READ, [ \&_tls_accept, $self, $fo ]);
673             } elsif ($SSL_ERROR == $SSL_WANT_WRITE) {
674 0 0       0 $DEBUG && DEBUG(40,"TLS accept - want write");
675 0 0       0 $self->{loop}->delFD($xxfd, EV_READ) if $xxfd;
676 0         0 $self->{loop}->addFD($fo->{fd}, EV_WRITE,
677             [ \&_tls_accept, $self, $fo ]);
678             } else {
679             # permanent error
680 0         0 _del_socket($self, $fo,
681             "SSL accept failed: $SSL_ERROR");
682             }
683             }
684              
685              
686             sub _tls_connect {
687 15     15   47 my Net::SIP::SocketPool $self = shift;
688 15         52 my ($fo,$callback,$xxfd) = @_;
689 15 100       66 if (!$xxfd) {
690 5 50       36 $DEBUG && DEBUG(40,"upgrade to SSL client");
691             IO::Socket::SSL->start_SSL($fo->{fd},
692             SSL_verifycn_name => $fo->{peer}{host},
693             SSL_hostname => $fo->{peer}{host},
694 5 50       34 %{$self->{tls}{c}},
  5         159  
695             SSL_startHandshake => 0,
696             ) or die "upgrade to SSL socket failed: $SSL_ERROR";
697             }
698              
699 15 100       1116 if ($fo->{fd}->connect_SSL()) {
700             $DEBUG && DEBUG(40,"TLS connect success peer cert=%s",
701 5 50       1055 _dump_certificate($fo->{fd}->peer_certificate));
702 5         31 delete $fo->{inside_connect};
703 5 50       70 $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd;
704 5         62 _addreader2loop($self,$fo);
705 5 50       103 return _tcp_send($self,$fo,$callback) if $fo->{wbuf} ne '';
706 0         0 invoke_callback($callback,0);
707 0         0 return;
708             }
709              
710 10 50       10179 if ($SSL_ERROR == $SSL_WANT_READ) {
    0          
711 10 50       73 $DEBUG && DEBUG(40,"TLS connect - want read");
712 10 100       86 $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd;
713 10         92 $self->{loop}->addFD($fo->{fd}, EV_READ,
714             [ \&_tls_connect, $self, $fo, $callback ]);
715             } elsif ($SSL_ERROR == $SSL_WANT_WRITE) {
716 0 0       0 $DEBUG && DEBUG(40,"TLS connect - want write");
717 0 0       0 $self->{loop}->delFD($xxfd, EV_READ) if $xxfd;
718 0         0 $self->{loop}->addFD($fo->{fd}, EV_WRITE,
719             [ \&_tls_connect, $self, $fo, $callback ]);
720             } else {
721             # permanent error
722 0         0 _del_socket($self, $fo,
723             "SSL connect failed: $SSL_ERROR");
724 0         0 invoke_callback($callback,"SSL connect failed: $SSL_ERROR");
725             }
726             }
727              
728              
729             sub _dump_certificate {
730 0 0   0   0 my $cert = shift or return '';
731 0         0 my $issuer = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name($cert));
732 0         0 my $subject = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($cert));
733 0         0 return "s:$subject i:$issuer";
734             }
735              
736             1;