File Coverage

blib/lib/Net/SIP/Leg.pm

Criterion	Covered	Total	%
statement	215	262	82.0
branch	93	166	56.0
condition	53	118	44.9
subroutine	30	33	90.9
pod	12	16	75.0
total	403	595	67.7

###########################################################################
# package Net::SIP::Leg
# a leg is a special kind of socket, which can send and receive SIP packets
# and manipulate transport relevant SIP header (Via,Record-Route)
###########################################################################

use strict;
use warnings;

package Net::SIP::Leg;
use Digest::MD5 'md5_hex';
use Socket;
use Net::SIP::Debug;
use Net::SIP::Util ':all';
use Net::SIP::SocketPool;
use Net::SIP::Packet;
use Net::SIP::Request;
use Net::SIP::Response;
use Errno qw(EHOSTUNREACH EINVAL);
use Hash::Util 'lock_ref_keys';
use Carp;

use fields qw(contact branch via proto src socketpool);

# sock: the socket for the leg
# src: hash addr,port,family where it receives data and sends data from
# proto: udp|tcp
# contact: to identify myself (default from addr:port)
# branch: base for branch-tag for via header
# via: precomputed part of via value

###########################################################################
# create a new leg
# Args: ($class,%args)
#   %args: hash, the following keys will be used and deleted from hash
#      proto: udp|tcp|tls. If not given will be determined from 'sock' or will
#        default to 'udp' or 'tls' (if 'tls' arg is used)
#      host,addr,port,family: source of outgoing and destination of
#        incoming data.
#        If IP address addr not given these values will be determined from
#        'sock'. Otherwise port will default to 5060 or 5061 (tls) and family
#        will be determined from addr syntax. host will default to addr
#      dst: destination for this leg in case a fixed destination is used
#        if not given 'sock' will be checked if connected
#      sock: socket which can just be used
#        if not given will create new socket based on proto, addr, port
#        if dst is given this new socket will be connected (udp only)
#      socketpool: socketpool which can just be used
#        if not given a new SocketPool object will be created based on the given
#        'sock' or the created socket (addr, port...). 'sock' and 'socketpool'
#        must not be given both.
#      tls: optional configuration parameters for IO::Socket::SSL. Implies
#        use of proto 'tls'.
#      contact: contact information
#        default will be based on addr and port
#      branch: branch informaton
#        default will be based on proto, addr, port
# Returns: $self - new leg object
###########################################################################
sub new {
    my ($class,%args) = @_;
    my $self = fields::new($class);

    my $proto = delete $args{proto};
    my $dst = delete $args{dst};
    my $tls = delete $args{tls};
    $proto ||= 'tls' if $tls;

    my ($sip_proto,$default_port) = $proto && $proto eq 'tls'
	? ('sips',5061) : ('sip',5060);

    my $family;
    my $host = delete $args{host};
    if (my $addr = delete $args{addr}) {
	my $port = delete $args{port};
	my $family = delete $args{family};
	if (!$family) {
	    ($addr,my $port_a, $family) = ip_string2parts($addr);
	    die "port given both as argument and contained in address"
		if $port && $port_a && $port != $port_a;
	    $port = $port_a if $port_a;
	}
	# port defined and 0 -> get port from system
	$port = $default_port if ! defined $port;
	$self->{src} = lock_ref_keys({
	    host   => $host || $addr,
	    addr   => $addr,
	    port   => $port,
	    family => $family
	});
    }

    if ($dst && !ref($dst)) {
	my ($ip,$port,$family) = ip_string2parts($dst);
	$family or die "destination must contain IP address";
	$dst = lock_ref_keys({
	    host   => $ip,
	    addr   => $ip,
	    port   => $port,
	    family => $family,
	});
    }

    my $sock = delete $args{sock};
    my $socketpool = delete $args{socketpool};
    die "only socketpool or sock should be given" if $sock && $socketpool;
    $sock ||= $socketpool && $socketpool->master;

    my $sockpeer = undef;
    if (!$sock) {
	# create new socket
	$proto ||= 'udp';
	my $src = $self->{src};
	if (!$src) {
	    # no src given, try to get useable soure from dst
	    die "neither source, destination nor socket given" if !$dst;
	    my $srcip = laddr4dst($dst->{addr}) or die
		"cannot find local IP when connecting to $dst->{addr}";
	    $src = $self->{src} = lock_ref_keys({
		host   => $host || $srcip,
		addr   => $srcip,
		port   => 0,
		family => $dst->{family},
	    });
	}

	croak("addr must be IP address") if ! ip_is_v46($src->{addr});

	my %sockargs = (
	    Proto     => $proto eq 'tls' ? 'tcp' : $proto,
	    Family    => $src->{family},
	    LocalAddr => $src->{addr},
	    Reuse     => 1, ReuseAddr => 1,
	);
	if ($proto eq 'tcp' or $proto eq 'tls') {
	    # with TCP we create a listening socket
	    $sockargs{Listen} = 100;
	} elsif ($dst) {
	    # with UDP we can create a connected socket if dst is given
	    $sockargs{PeerAddr} = $dst->{addr};
	    $sockargs{PeerPort} = $dst->{port} ||= $default_port;
	    $sockpeer = $dst;
	}

	# create a socket with the given local port
	# if no port is given try 5060,5062.. or let the system pick one
	for my $port ($src->{port}
	    ? $src->{port}
	    : ($default_port, 5062..5100, 0)) {
	    last if $sock = INETSOCK(%sockargs, LocalPort => $port);
	}

	$sock or die "failed to bind to " . ip_parts2string($src).": $!";
	$src->{port} ||= $sock->sockport;
	DEBUG(90,"created socket on ".ip_parts2string($src));

    } else {
	# get proto from socket
	$proto ||= $sock->socktype == SOCK_DGRAM ? 'udp':'tcp';

	# get src from socket
	if (!$self->{src}) {
	    my $saddr = getsockname($sock) or die
		"cannot get local name from provided socket: $!";
	    $self->{src} = ip_sockaddr2parts($saddr);
	    $self->{src}{host} = $host if $host;
	}
	if (!$dst and my $saddr = getpeername($sock)) {
	    # set dst from connected socket
	    $sockpeer = $dst = ip_sockaddr2parts($saddr);
	}
    }

    # create socketpool and add primary socket of leg to it if needed
    $self->{socketpool} = $socketpool ||= Net::SIP::SocketPool->new(
	$proto, $sock, $dst, $sockpeer, $tls);

    my $leg_addr = ip_parts2string({
	%{$self->{src}},
	use_host => 1, # prefer hostname
	default_port => $default_port,
    }, 1);  # use "[ipv6]" even if no port is given
    $self->{contact}  = delete $args{contact} || "$sip_proto:$leg_addr";

    $self->{branch} = 'z9hG4bK'. (
	delete $args{branch}
	|| md5_hex(@{$self->{src}}{qw(addr port)}, $proto)  # ip, port, proto
    );

    $self->{via} =  sprintf( "SIP/2.0/%s %s;branch=",
	uc($proto),$leg_addr );
    $self->{proto} = $proto;

    die "unhandled arguments: ".join(", ", keys %args) if %args;

    return $self;
}

###########################################################################
# do we need retransmits on this leg?
# Args: $self
# Returns: 1|0
#   1: need retransmits (UDP)
#   0: don't need retransmits (TCP, TLS)
###########################################################################
sub do_retransmits {
    my Net::SIP::Leg $self = shift;
    return $self->{proto} eq 'udp' ? 1 : 0;
}

###########################################################################
# prepare incoming packet for forwarding
# Args: ($self,$packet)
#   $packet: incoming Net::SIP::Packet, gets modified in-place
# Returns: undef | [code,text]
#   code: error code (can be empty if just drop packet on error)
#   text: error description (e.g max-forwards reached..)
###########################################################################
sub forward_incoming {
    my Net::SIP::Leg $self = shift;
    my ($packet) = @_;

    if ( $packet->is_response ) {
	# remove top via
	my $via;
	$packet->scan_header( via => [ sub {
	    my ($vref,$hdr) = @_;
	    if ( !$$vref ) {
		$$vref = $hdr->{value};
		$hdr->remove;
	    }
	}, \$via ]);

    } else {
	# Request

	# Max-Fowards
	my $maxf = $packet->get_header( 'max-forwards' );
	# we don't want to put somebody Max-Forwards: 7363535353 into the header
	# and then crafting a loop, so limit it to the default value
	$maxf = 70 if !$maxf || $maxf>70;
	$maxf--;
	if ( $maxf <= 0 ) {
	    # just drop
	    DEBUG( 10,'reached max-forwards. DROP' );
	    return [ undef,'max-forwards reached 0, dropping' ];
	}
	$packet->set_header( 'max-forwards',$maxf );

	# check if last hop was strict router
	# remove myself from route
	my $uri = $packet->uri;
	$uri = $1 if $uri =~m{^<(.*)>};
	($uri) = sip_hdrval2parts( route => $uri );
	my $remove_route;
	if ( $uri eq $self->{contact} ) {
	    # last router placed myself into URI -> strict router
	    # get original URI back from last Route-header
	    my @route = $packet->get_header( 'route' );
	    if ( !@route ) {
		# ooops, no route headers? -> DROP
		return [ '','request from strict router contained no route headers' ];
	    }
	    $remove_route = $#route;
	    $uri = $route[-1];
	    $uri = $1 if $uri =~m{^<(.*)>};
	    $packet->set_uri($uri);

	} else {
	    # last router was loose,remove top route if it is myself
	    my @route = $packet->get_header( 'route' );
	    if ( @route ) {
		my $route = $route[0];
		$route = $1 if $route =~m{^<(.*)>};
		($route) = sip_hdrval2parts( route => $route );
		if ( sip_uri_eq( $route,$self->{contact}) ) {
		    # top route was me
		    $remove_route = 0;
		}
	    }
	}
	if ( defined $remove_route ) {
	    $packet->scan_header( route => [ sub {
		my ($rr,$hdr) = @_;
		$hdr->remove if $$rr-- == 0;
	    }, \$remove_route]);
	}

	# Add Record-Route to request, except
	# to REGISTER (RFC3261, 10.2)
	$packet->insert_header( 'record-route', '<'.$self->{contact}.';lr>' )
	    if $packet->method ne 'REGISTER';
    }

    return;
}

###########################################################################
# prepare packet which gets forwarded through this leg
# packet was processed before by forward_incoming on (usually) another
# leg on the same dispatcher.
# Args: ($self,$packet,$incoming_leg)
#   $packet: outgoing Net::SIP::Packet, gets modified in-place
#   $incoming_leg: leg where packet came in
# Returns: undef | [code,text]
#   code: error code (can be empty if just drop packet on error)
#   text: error description (e.g max-forwards reached..)
###########################################################################
sub forward_outgoing {
    my Net::SIP::Leg $self = shift;
    my ($packet,$incoming_leg) = @_;

    if ( $packet->is_request ) {
	# check if myself is already in Via-path
	# in this case drop the packet, because a loop is detected
	if ( my @via = $packet->get_header( 'via' )) {
	    my $branch = $self->via_branch($packet,3);
	    foreach my $via ( @via ) {
		my (undef,$param) = sip_hdrval2parts( via => $via );
		# ignore via header w/o branch, although these don't conform to
		# RFC 3261, sect 8.1.1.7
		defined $param->{branch} or next;
		if ( substr( $param->{branch},0,length($branch) ) eq $branch ) {
		    DEBUG( 10,'loop detected because outgoing leg is in Via. DROP' );
		    return [ undef,'loop detected on outgoing leg, dropping' ];
		}
	    }
	}

	# Add Record-Route to request, except
	# to REGISTER (RFC3261, 10.2)
	# This is necessary, because these information are used in in new requests
	# from UAC to UAS, but also from UAS to UAC and UAS should talk to this leg
	# and not to the leg, where the request came in.
	# don't add if the upper record-route is already me, this is the case
	# when incoming and outgoing leg are the same
	if ( $packet->method ne 'REGISTER' ) {
	    my $rr;
	    unless ( (($rr) = $packet->get_header( 'record-route' ))
		and sip_uri_eq( $rr,$self->{contact} )) {
		$packet->insert_header( 'record-route', '<'.$self->{contact}.';lr>' )
	    }
	}

	# strip myself from route header, because I'm done
	if ( my @route = $packet->get_header( 'route' ) ) {
	    my $route = $route[0];
	    $route = $1 if $route =~m{^<(.*)>};
	    ($route) = sip_hdrval2parts( route => $route );
	    if ( sip_uri_eq( $route,$self->{contact} )) {
		# top route was me, remove it
		my $remove_route = 0;
		$packet->scan_header( route => [ sub {
		    my ($rr,$hdr) = @_;
		    $hdr->remove if $$rr-- == 0;
		}, \$remove_route]);
	    }
	}
    }
    return;
}


###########################################################################
# deliver packet through this leg to specified addr
# add local Via header to requests
# Args: ($self,$packet,$dst;$callback)
#   $packet: Net::SIP::Packet
#   $dst:    target for delivery as hash host,addr,port,family
#   $callback: optional callback, if an error occurred the callback will
#      be called with $! as argument. If no error occurred and the
#      proto is tcp the callback will be called with error=0 to show
#      that the packet was definitely delivered (and there's no need to retry)
###########################################################################
sub deliver {
    my Net::SIP::Leg $self = shift;
    my ($packet,$dst,$callback) = @_;

    my $isrq = $packet->is_request;
    if ( $isrq ) {
	# add via,
	# clone packet, because I don't want to change the original
	# one because it might be retried later
	# (could skip this for tcp?)
	$packet = $packet->clone;
	$self->add_via($packet);
    }

    # 2xx responses to INVITE requests and the request itself must have a
    # Contact, Allow and Supported header, 2xx Responses to OPTIONS need
    # Allow and Supported, 405 Responses should have Allow and Supported

    my ($need_contact,$need_allow,$need_supported);
    my $method = $packet->method;
    my $code = ! $isrq && $packet->code;
    if ( $method eq 'INVITE' and ( $isrq or $code =~m{^2} )) {
	$need_contact = $need_allow = $need_supported =1;
    } elsif ( !$isrq and (
	$code == 405 or
	( $method eq 'OPTIONS'  and $code =~m{^2} ))) {
	$need_allow = $need_supported =1;
    }
    if ( $need_contact && ! ( my @a = $packet->get_header( 'contact' ))) {
	# needs contact header, create from this leg and user part of from/to
	my ($user) = sip_hdrval2parts( $isrq
	    ? ( from => scalar($packet->get_header('from')) )
	    : ( to   => scalar($packet->get_header('to')) )
	);
	my ($proto,$addr) = $self->{contact} =~m{^(\w+):(?:.*\@)?(.*)$};
	my $contact = ( $user =~m{([^<>\@\s]+)\@} ? $1 : $user ).
	    "\@$addr";
	$contact = $proto.':'.$contact if $contact !~m{^\w+:};
	$contact = "<$contact>" if $contact =~m{;};
	$packet->insert_header( contact => $contact );
    }
    if ( $need_allow && ! ( my @a = $packet->get_header( 'allow' ))) {
	# insert default methods
	$packet->insert_header( allow => 'INVITE, ACK, OPTIONS, CANCEL, BYE' );
    }
    if ( $need_supported && ! ( my @a = $packet->get_header( 'supported' ))) {
	# set as empty
	$packet->insert_header( supported => '' );
    }

    die "target protocol $dst->{proto} does not match leg $self->{proto}"
	if exists $dst->{proto} && $dst->{proto} ne $self->{proto};
    $dst->{port} ||= $self->{proto} eq 'tls' ? 5061 : 5060;

    $DEBUG && DEBUG( 2, "delivery with %s from %s to %s:\n%s",
	$self->{proto},
	ip_parts2string($self->{src}),
	ip_parts2string($dst),
	$packet->dump( Net::SIP::Debug->level -2 ) );

    return $self->sendto($packet,$dst,$callback);
}

###########################################################################
# send data to peer
# Args: ($self,$packet,$dst,$callback)
#   $packet: SIP packet object
#   $dst:   target as hash host,addr,port,family
#   $callback: callback for error|success, see method deliver
# Returns: $success
#   $success: true if no problems occurred while sending (this does not
#     mean that the packet was delivered reliable!)
###########################################################################
sub sendto {
    my Net::SIP::Leg $self = shift;
    my ($packet,$dst,$callback) = @_;

    $self->{socketpool}->sendto($packet,$dst,$callback)
	&& return 1;
    return;
}

###########################################################################
# Handle newly received packet.
# Currently just passes through the packet
# Args: ($self,$packet,$from)
#   $packet: packet object
#   $from: hash with proto,addr,port,family where the packet came from
# Returns: ($packet,$from)|()
#   $packet: packet object
#   $from: hash with proto,ip,port,family where the packet came from
###########################################################################
sub receive {
    my Net::SIP::Leg $self = shift;
    my ($packet,$from) = @_;

    $DEBUG && DEBUG( 2,"received packet on %s from %s:\n%s",
	sip_sockinfo2uri($self->{proto},@{$self->{src}}{qw(addr port family)}),
	sip_sockinfo2uri(@{$from}{qw(proto addr port family)}),
	$packet->dump( Net::SIP::Debug->level -2 )
    );
    return ($packet,$from);
}


###########################################################################
# check if the top via header matches the transport of this call through
# this leg. Used to strip Via header in response.
# Args: ($self,$packet)
#  $packet: Net::SIP::Packet (usually Net::SIP::Response)
# Returns: $bool
#  $bool: true if the packets via matches this leg, else false
###########################################################################
sub check_via {
    my ($self,$packet) = @_;
    my ($via) = $packet->get_header( 'via' );
    my ($data,$param) = sip_hdrval2parts( via => $via );
    my $cmp_branch = $self->via_branch($packet,2);
    return substr( $param->{branch},0,length($cmp_branch)) eq $cmp_branch;
}

###########################################################################
# add myself as Via header to packet
# Args: ($self,$packet)
#  $packet: Net::SIP::Packet (usually Net::SIP::Request)
# Returns: NONE
# modifies packet in-place
###########################################################################
sub add_via {
    my Net::SIP::Leg $self = shift;
    my $packet = shift;
    $packet->insert_header( via => $self->{via}.$self->via_branch($packet,3));
}

###########################################################################
# computes branch tag for via header
# Args: ($self,$packet,$level)
#  $packet: Net::SIP::Packet (usually Net::SIP::Request)
#  $level: level of detail: 1:leg, 2:call, 3:path
# Returns: $value
###########################################################################
sub via_branch {
    my Net::SIP::Leg $self = shift;
    my ($packet,$level) = @_;
    my $val = $self->{branch};
    $val .= substr( md5_hex( $packet->tid ),0,15 ) if $level>1;
    if ($level>2) {
	my @parts;
	# RT#120816 -  take only known constant values from proxy-authorization
	for(sort $packet->get_header('proxy-authorization')) {
	    my ($typ,$param) = sip_hdrval2parts('proxy-authorization' => $_);
	    push @parts,$typ;
	    for(qw(realm username domain qop algorithm)) {
		push @parts,"$_=$param->{$_}" if exists $param->{$_};
	    }
	}

	# RT#120816 - include only the branch from via header if possible
	if (my $via = ($packet->get_header('via'))[0]) {
	    my (undef,$param) = sip_hdrval2parts(via => $via);
	    push @parts, $param && $param->{branch} || $via;
	}

	push @parts,
	    ( sort $packet->get_header('proxy-require')),
	    $packet->get_header('route'),
	    $packet->get_header('from'),
	    ($packet->as_parts())[1]; # URI
	$val .= substr(md5_hex(@parts),0,15);
    }
    return $val;
}

###########################################################################
# check if the leg could deliver to the specified addr
# Args: ($self,($addr|%spec))
#  $addr: addr|proto:addr|addr:port|proto:addr:port
#  %spec: hash with keys addr,proto,port
# Returns: $bool
#  $bool: true if we can deliver to $ip with $proto
###########################################################################
sub can_deliver_to {
    my Net::SIP::Leg $self = shift;
    my %spec;
    if (@_>1) {
	%spec = @_;
    } else {
	@spec{ qw(proto host port family) } = sip_uri2sockinfo(shift());
	$spec{addr} = $spec{family} ? $spec{host} : undef;
    }

    # return false if proto or family don't match
    return if $spec{proto} && $spec{proto} ne $self->{proto};
    return if $spec{family} && $self->{src}
	&& $self->{src}{family} != $spec{family};

    # XXXXX dont know how to find out if I can deliver to this addr from this
    # leg without lookup up route
    # therefore just return true and if you have more than one leg you have
    # to figure out yourself where to send it
    return 1
}

###########################################################################
# check if this leg matches given criteria (used in Dispatcher)
# Args: ($self,$args)
#   $args: hash with any of 'addr', 'port', 'proto', 'sub'
# Returns: true if leg fits all args
###########################################################################
sub match {
    my Net::SIP::Leg $self = shift;
    my $args = shift;
    return if $args->{addr}
	&& $args->{addr} ne $self->{src}{addr}
	&& $args->{addr} ne $self->{src}{host};
    return if $args->{port}  && $args->{port}  != $self->{src}{port};
    return if $args->{proto} && $args->{proto} ne $self->{proto};
    return if $args->{sub}   && !invoke_callback($args->{sub},$self);
    return 1;
}

###########################################################################
# returns SocketPool object on Leg
# Args: $self
# Returns: $socketpool
###########################################################################
sub socketpool {
    my Net::SIP::Leg $self = shift;
    return $self->{socketpool};
}

###########################################################################
# local address of the leg
# Args: $self;$parts
#  $parts: number of parts to include
#     0 -> address only
#     1 -> address[:non_default_port]
#     2 -> host[:non_default_port]
# Returns: string
###########################################################################
sub laddr {
    my Net::SIP::Leg $self = shift;
    my $parts = shift;
    ! $parts and return $self->{src}{addr};
    return ip_parts2string({
	%{ $self->{src} },
	default_port => $self->{proto} eq 'tls' ? 5061 : 5060,
	$parts == 1 ? () :
	$parts == 2 ? (use_host => 1) :
	die "invalid parts specification $parts",
    });
}

###########################################################################
# some info about the Leg for debugging
# Args: $self
# Returns: string
###########################################################################
sub dump {
    my Net::SIP::Leg $self = shift;
    return ref($self)." $self->{proto}:"
	. ip_parts2string($self->{src});
}


###########################################################################
# returns key for leg
# Args: $self
# Returns: key (string)
###########################################################################
sub key {
    my Net::SIP::Leg $self = shift;
    return ref($self).' '.join(':',$self->{proto},
	@{$self->{src}}{qw(addr port)});
}

1;