libnet-sip-perl 0.66-1 / usr / share / perl5 / Net / SIP / Dispatcher.pm

###########################################################################
# package Net::SIP::Dispatcher
#
# Manages the sending of SIP packets to the legs (and finding out which
# leg can be used) and the receiving of SIP packets and forwarding to
# the upper layer.
# Handles retransmits
###########################################################################

use strict;
use warnings;

package Net::SIP::Dispatcher;
use fields (
	# interface to outside
	'receiver',       # callback into upper layer
	'legs',           # \@list of Net::SIP::Legs managed by dispatcher
	'eventloop',      # Net::SIP::Dispatcher::Eventloop or similar
	'outgoing_proxy', # optional fixed outgoing proxy
	'domain2proxy',   # optional mapping between SIP domains and proxies (otherwise use DNS)
	# internals
	'do_retransmits', # flag if retransmits will be done (false for stateless proxy)
	'queue',          # \@list of outstanding Net::SIP::Dispatcher::Packet
	'response_cache', # Cache of responses, used to reply to retransmits
	'disp_expire',    # expire/retransmit timer
);

use Net::SIP::Leg;
use Net::SIP::Util ':all';
use Errno qw(EHOSTUNREACH ETIMEDOUT ENOPROTOOPT EINVAL);
use IO::Socket;
use List::Util 'first';
use Net::DNS;
use Carp 'croak';
use Net::SIP::Debug;
use Scalar::Util 'weaken';


###########################################################################
# create new dispatcher
# Args: ($class,$legs,$eventloop;%args)
#  $legs:           \@array, see add_leg()
#  $eventloop:      Net::SIP::Dispatcher::Eventloop or similar
#  %args:
#   outgoing_proxy: optional outgoing proxy (ip:port)
#   do_retransmits: set if the dispatcher has to handle retransmits by itself
#       defaults to true
#   domain2proxy: mappings { domain => proxy } if a fixed proxy is used
#       for specific domains, otherwise lookup will be done per DNS
#       proxy can be ip,ip:port or \@list of [ prio,proto,ip,port ] like
#       in the DNS SRV record.
#       with special domain '*' a default can be specified, so that DNS
#       will not be used at all
# Returns: $self
###########################################################################
sub new {
	my ($class,$legs,$eventloop,%args) = @_;

	my ($outgoing_proxy,$do_retransmits,$domain2proxy)
		= delete @args{qw( outgoing_proxy do_retransmits domain2proxy )};
	die "bad args: ".join( ' ',keys %args ) if %args;

	$eventloop ||= Net::SIP::Dispatcher::Eventloop->new;

	# normalize domain2proxy so that its the same format one gets from
	# the SRV record
	$domain2proxy ||= {};
	foreach ( values %$domain2proxy ) {
		if ( ref($_) ) { # should be \@list of [ prio,proto,ip,port ]
		} elsif ( m{^(?:(udp|tcp):)?([^:]+)(?::(\d+))?$} ) {
			my @proto = $1 ? ( $1 ) : ( 'udp','tcp' );
			my $host = $2;
			my $port = $3 || 5060;
			$_ = [ map { [ -1, $_, $host, $port ] } @proto ];
		} else {
			croak( "invalid entry in domain2proxy: $_" );
		}
	}

	my $self = fields::new($class);
	%$self = (
		legs => [],
		queue  => [],
		outgoing_proxy => undef,
		response_cache => {},
		do_retransmits => defined( $do_retransmits ) ? $do_retransmits : 1,
		eventloop => $eventloop,
		domain2proxy => $domain2proxy,
	);

	$self->add_leg( @$legs );

	if ( $outgoing_proxy ) {
		my $leg = $self->_find_leg4addr( $outgoing_proxy )
			|| die "cannot find leg for destination $outgoing_proxy";
		$self->{outgoing_proxy} = $outgoing_proxy;
	}


	# regularly prune queue
	my $sub = sub {
		my ($self,$timer) = @_;
		if ( $self ) {
			$self->queue_expire( $self->{eventloop}->looptime );
		} else {
			$timer->cancel;
		}
	};
	my $cb = [ $sub,$self ];
	weaken( $cb->[1] );
	$self->{disp_expire} = $self->add_timer( 1,$cb,1,'disp_expire' );

	return $self;
}

###########################################################################
# set receiver, e.g the upper layer which gets the incoming packets
# received by the dispatcher
# Args: ($self,$receiver)
#   $receiver: object which has receive( Net::SIP::Leg,Net::SIP::Packet )
#     method to handle incoming SIP packets or callback
#     might be undef - in this case the existing receiver will be removed
# Returns: NONE
###########################################################################
sub set_receiver {
	my Net::SIP::Dispatcher $self = shift;
	if ( my $receiver = shift ) {
		if ( my $sub = UNIVERSAL::can($receiver,'receive' )) {
			# Object with method receive()
			$receiver = [ $sub,$receiver ]
		}
		$self->{receiver} = $receiver;
	} else {
		# remove receiver
		$self->{receiver} = undef
	}

}

###########################################################################
# adds a leg to the dispatcher
# Args: ($self,@legs)
#  @legs: can be sockets, \%args for constructing or already
#    objects of class Net::SIP::Leg
# Returns: NONE
###########################################################################
sub add_leg {
	my Net::SIP::Dispatcher $self = shift;
	my $legs = $self->{legs};
	foreach my $arg (@_) {

		my $leg;
		# if it is not a leg yet create one based
		# on the arguments
		if ( UNIVERSAL::isa( $arg,'Net::SIP::Leg' )) {
			# already a leg
			$leg = $arg;

		} elsif ( UNIVERSAL::isa( $arg,'IO::Handle' )) {
			# create from socket
			$leg = Net::SIP::Leg->new( sock => $arg );

		} elsif ( UNIVERSAL::isa( $arg,'HASH' )) {
			# create from %args
			$leg = Net::SIP::Leg->new( %$arg );
		} else {
			croak "invalid spec for leg: $arg";
		}

		push @$legs, $leg;

		if ( my $fd = $leg->fd ) {
			my $cb = sub {
				# don't crash Dispatcher on bad or unexpected packets
				eval {
					my ($self,$leg) = @_;
					$self || return;

					# leg->receive might return undef if the packet wasnt
					# read successfully. for tcp connections the receive
					# on a listening socket might cause a new leg to be added
					# which then will receive the packet (maybe over multiple
					# read attempts)
					my ($packet,$from) = $leg->receive or do {
						DEBUG( 50,"failed to receive on leg" );
						return;
					};

					if ($packet->is_request) {
						# add received and rport to top via
						$packet->scan_header( via => [ sub {
							my ($vref,$hdr) = @_;
							return if $$vref++;
							my ($d,$h) = sip_hdrval2parts(via => $hdr->{value});
							# FIXME: not IPv6 save
							my ($host,$port) = $d =~m{^\S+\s+(\S+?)(?::(\d+))?$};
							my ($addr,$rport) = $from =~m{^(\S+)(?::(\d+))$};
							my %nh;
							if ( exists $h->{rport} and ! defined $h->{rport}) {
								$nh{rport} = $rport;
							}
							if ( $host ne $addr or $nh{rport}) { 
								# either hostname or different IP or required because
								# rport was set
								$nh{received} = $addr;
							}
							if (%nh) {
								$hdr->{value} = sip_parts2hdrval('via',$d,{ %$h,%nh});
								$hdr->set_modified;
							}
						}, \( my $cvia )]);
					}

					# handle received packet
					$self->receive( $packet,$leg,$from );


				};
				if ($@) {
					DEBUG(1,"dispatcher croaked: $@");
				}
			};
			$cb = [ $cb,$self,$leg ];
			weaken( $cb->[1] );
			$self->{eventloop}->addFD( $fd, $cb );
		}
	}
}

###########################################################################
# remove a leg from the dispatcher
# Args: ($self,@legs)
#  @legs: Net::SIP::Leg objects
# Returns: NONE
###########################################################################
sub remove_leg {
	my Net::SIP::Dispatcher $self = shift;
	my $legs = $self->{legs};
	foreach my $leg (@_) {
		@$legs = grep { $_ != $leg } @$legs;
		if ( my $fd = $leg->fd ) {
			$self->{eventloop}->delFD( $fd );
		}
	}
}

###########################################################################
# find legs matching specific criterias
# Args: ($self,%args)
#  %args: Hash with some of these keys
#    addr: leg must match addr
#    port: leg must match port
#    proto: leg must match proto
#    sock: leg must match sock
#    sub:  $sub->($leg) must return true
# Returns: @legs
#   @legs: all Legs matching the criteria
# Comment:
# if no criteria given it will return all legs
###########################################################################
sub get_legs {
	my Net::SIP::Dispatcher $self = shift;
	return @{ $self->{legs} } if ! @_; # shortcut

	my %args = @_;
	my @rv;
	foreach my $leg (@{ $self->{legs} }) {
		next if $args{addr} && $args{addr} ne $leg->{addr};
		next if $args{port} && $args{port} != $leg->{port};
		next if $args{proto} && $args{proto} ne $leg->{proto};
		next if $args{sock} && $args{sock} != $leg->{sock};
		next if $args{sub} && !invoke_callback( $args{sub},$leg );
		push @rv,$leg
	}
	return @rv;
}


###########################################################################
# add timer
# propagates to add_timer of eventloop
# Args: ($self,$when,$cb,$repeat)
#   $when: when callback gets called, can be absolute time (epoch, time_t)
#     or relative time (seconds)
#   $cb: callback
#   $repeat: after how much seconds it gets repeated (default 0, e.g never)
# Returns: $timer
#   $timer: Timer object, has method cancel for canceling timer
###########################################################################
sub add_timer {
	my Net::SIP::Dispatcher $self = shift;
	return $self->{eventloop}->add_timer( @_ );
}

###########################################################################
# initiate delivery of a packet, e.g. put packet into delivery queue
# Args: ($self,$packet,%more_args)
#   $packet: Net::SIP::Packet which needs to be delivered
#   %more_args: hash with some of the following keys
#     id:        id for packet, used in cancel_delivery
#     callback:  [ \&sub,@arg ] for calling back on definite delivery
#       success (tcp only) or error (timeout,no route,...)
#     leg:       specify outgoing leg, needed for responses
#     dst_addr:  specify outgoing addr [ip,port] or sockaddr, needed
#       for responses
#     do_retransmits: if retransmits should be done, default from
#        global value (see new())
# Returns: NONE
# Comment: no return value, but die()s on errors
###########################################################################
sub deliver {
	my Net::SIP::Dispatcher $self = shift;
	my ($packet,%more_args) = @_;
	my $now = delete $more_args{now};
	my $do_retransmits = delete $more_args{do_retransmits};
	$do_retransmits = $self->{do_retransmits} if !defined $do_retransmits;

	DEBUG( 100,"deliver $packet" );

	if ( $packet->is_response ) {
		# cache response for 32 sec (64*T1)
		if ( $do_retransmits ) {
			my $cid = join( "\0",
				map { $packet->get_header($_) }
				qw( cseq call-id from to )
			);
			$self->{response_cache}{$cid} = {
				packet => $packet,
				expire => ( $now ||= time()) +32
			};
		}
	}

	my $new_entry = Net::SIP::Dispatcher::Packet->new(
		packet => $packet,
		%more_args
	);

	$new_entry->prepare_retransmits( $now ) if $do_retransmits;

	push @{ $self->{queue}}, $new_entry;
	$self->__deliver( $new_entry );
}

###########################################################################
# cancel delivery of all packets with specific id
# Args: ($self,$typ?,$id)
#   $typ: what to cancel, e.g. 'id','callid' or 'qentry', optional,
#     defaults to 'id' if $id is not ref or 'qentry' if $id is ref
#   $id: id to cancel, can also be queue entry
# Returns: bool, true if the was something canceled
###########################################################################
sub cancel_delivery {
	my Net::SIP::Dispatcher $self = shift;
	my ($callid,$id,$qentry);
	if ( @_ == 2 ) {
		my $typ = shift;
		if ( $typ eq 'callid' ) { $callid = shift }
		elsif ( $typ eq 'id' ) { $id = shift }
		elsif ( $typ eq 'qentry' ) { $qentry = shift }
		else {
			croak( "bad typ '$typ', should be id|callid|qentry" );
		}
	} else {
		$id = shift;
		if ( ref($id)) {
			$qentry = $id;
			$id = undef;
		}
	}
	my $q = $self->{queue};
	my $qn = @$q;
	if ( $qentry ) {
		# it's a *::Dispatcher::Packet
		DEBUG( 100,"cancel packet id: $qentry->{id}" );
		@$q = grep { $_ != $qentry } @$q;
	} elsif ( defined $id ) {
		no warnings; # $_->{id} can be undef
		DEBUG( 100, "cancel packet id $id" );
		@$q = grep { $_->{id} ne $id } @$q;
	} elsif ( defined $callid ) {
		no warnings; # $_->{callid} can be undef
		DEBUG( 100, "cancel packet callid $callid" );
		@$q = grep { $_->{callid} ne $callid } @$q;
	} else {
		croak( "cancel_delivery w/o id" );
	}
	return @$q < $qn; # true if items got deleted
}



###########################################################################
# Receive a packet from a leg and forward it to the upper layer
# if the packet is a request and I have a cached response resend it
# w/o involving the upper layer
# Args: ($self,$packet,$leg,$from)
#   $packet: Net::SIP::Packet
#   $leg:    through which leg it was received
#   $from:   where the packet comes from (ip:port)
# Returns: NONE
# Comment: if no receiver is defined using set_receiver the packet
#   will be silently dropped
###########################################################################
sub receive {
	my Net::SIP::Dispatcher $self = shift;
	my ($packet,$leg,$from) = @_;

	if ( $packet->is_request ) {
		my $cache = $self->{response_cache};
		if ( %$cache ) {
			my $cid = join( "\0",
				map { $packet->get_header($_) }
				qw( cseq call-id from to )
			);

			if ( my $response = $cache->{$cid} ) {
				# I have a cached response, use it
				$self->deliver($response->{packet}, leg => $leg, dst_addr => $from);
				return;
			}
		}
	}

	invoke_callback( $self->{receiver},$packet,$leg,$from );
}

###########################################################################
# expire the entries on the queue, eg removes expired entries and
# calls callback if necessary
# expires also the response cache
# Args: ($self;$time)
#   $time: expire regarding $time, if not given use time()
# Returns: undef|$min_expire
#   $min_expire: time when next thing expires (undef if nothing to expire)
###########################################################################
sub queue_expire {
	my Net::SIP::Dispatcher $self = shift;
	my $now = shift || $self->{eventloop}->looptime;

	# expire queue
	my $queue = $self->{queue};
	my (@nq,$changed,$min_expire);
	foreach my $qe (@$queue) {

		my $retransmit;
		if ( my $retransmits = $qe->{retransmits} ) {
			while ( @$retransmits && $retransmits->[0] < $now ) {
				$retransmit = shift(@$retransmits);
			}

			if ( !@$retransmits ) {
				# completly expired
				DEBUG( 50,"entry %s expired because expire=%.2f but now=%d", $qe->tid,$retransmit,$now );
				$changed++;
				$qe->trigger_callback( ETIMEDOUT );

				# don't put into new queue
				next;
			}

			if ( $retransmit ) {
				# need to retransmit the packet
				$self->__deliver( $qe );
			}

			my $next_retransmit = $retransmits->[0];
			if ( !defined($min_expire) || $next_retransmit<$min_expire ) {
				$min_expire = $next_retransmit
			}
		}
		push @nq,$qe;

	}
	$self->{queue} = \@nq if $changed;

	# expire response cache
	my $cache = $self->{response_cache};
	foreach my $cid ( keys %$cache ) {
		my $expire = $cache->{$cid}{expire};
		if ( $expire < $now ) {
			delete $cache->{$cid};
		} elsif ( !defined($min_expire) || $expire<$min_expire ) {
			$min_expire = $expire
		}
	}

	# return time to next expire for optimizations
	return $min_expire;
}


###########################################################################
# the real delivery of a queue entry:
# if no leg,addr try to determine them from request-URI
# prepare timeout handling
# Args: ($self,$qentry)
#   $qentry: Net::SIP::Dispatcher::Packet
# Returns: NONE
# Comment:
# this might be called several times for a queue entry, eg as a callback
# at the various stages (find leg,addr for URI needs DNS lookup which
# might be done asynchronous, eg callback driven, send might be callback
# driven for tcp connections which need connect, multiple writes...)
###########################################################################
sub __deliver {
	my Net::SIP::Dispatcher $self = shift;
	my $qentry = shift;

	# loop until leg und dst_addr are known, when we call leg->deliver
	my $leg = $qentry->{leg}[0];
	if ( $leg && @{ $qentry->{leg}}>1 ) {
		DEBUG( 50,"picking first of multiple legs: ".join( " ", map { $_->dump } @{ $qentry->{leg}} ));
	}
	my $dst_addr = $qentry->{dst_addr}[0];

	if ( ! $dst_addr || ! $leg) {

		# if explicit routes given use first route
		# else resolve URI from request

		my $uri;
		my $packet = $qentry->{packet};
		if ( my ($route) =  $packet->get_header( 'route' )) {
			($uri) = sip_hdrval2parts( route => $route );
		} else {
			$uri = $packet->uri;
		}

		DEBUG( 100,"no dst_addr or leg yet, uri='$uri'" );

		my $callback = sub {
			my ($self,$qentry,@error) = @_;
			if ( @error ) {
				$qentry->trigger_callback(@error);
				return $self->cancel_delivery( $qentry );
			} else {
				$self->__deliver($qentry);
			}
		};
		return $self->resolve_uri(
			$uri,
			$qentry->{dst_addr},
			$qentry->{leg},
			[ $callback, $self,$qentry ],
			$qentry->{proto},
		);
	}

	# I have leg and addr, send packet thru leg to addr
	my $cb = sub {
		my ($self,$qentry,$error) = @_;
		$self || return;
		if ( !$error  && $qentry->{retransmits} ) {
			# remove from queue even if timeout
			$self->cancel_delivery( $qentry );
		}
		$qentry->trigger_callback( $error );
	};

	# adds via on cloned packet, calls cb if definite success (tcp)
	# or error
	DEBUG( 50,"deliver through leg ".$leg->dump." \@$dst_addr" );
	weaken( my $rself = \$self );
	$cb = [ $cb,$self,$qentry ];
	weaken( $cb->[1] );
	$leg->deliver( $qentry->{packet},$dst_addr,$cb );

	if ( !$qentry->{retransmits} ) {
		# remove from queue if no timeout
		$self->cancel_delivery( $qentry );
	}
}



###########################################################################
# resolve URI, determine dst_addr and outgoing leg
# Args: ($self,$uri,$dst_addr,$legs,$callback;$allowed_proto,$allowed_legs)
#   $uri: URI to resolve
#   $dst_addr: reference to list where to put dst_addr
#   $legs: reference to list where to put leg
#   $callback: called with () if resolved successfully, else called
#      with @error
#   $allowed_proto: optional \@list of protocols (default udp,tcp). If given only
#      only these protocols will be considered and in this order.
#   $allowed_legs: optional list of legs which are allowed
# Returns: NONE
###########################################################################
sub resolve_uri {
	my Net::SIP::Dispatcher $self = shift;
	my ($uri,$dst_addr,$legs,$callback,$allowed_proto,$allowed_legs) = @_;

	# packet should be a request packet (see constructor of *::Dispatcher::Packet)
	my ($domain,$user,$sip_proto,undef,$param) = sip_uri2parts($uri);
	$domain or do {
		DEBUG( 50,"bad URI '$uri'" );
		return invoke_callback($callback, EHOSTUNREACH );
	};

	my @proto;
	my $default_port = 5060;
	# XXXX hack, better would be to really parse URI, see *::Util::sip_hdrval2parts
	if ( $sip_proto eq 'sips' ) {
		$default_port = 5061;
		@proto = 'tcp';
	} elsif ( my $p = $param->{transport} ) {
		# explicit spec of proto
		@proto = lc($p)
	} else {
		# XXXX maybe we should use tcp first if the packet has a specific
		# minimum length, udp should not be used at all if the packet size is > 2**16
		@proto = ( 'udp','tcp' );
	}

	# change @proto so that only the protocols from $allowed_proto are ini it
	# and that they are tried in the order from $allowed_proto
	if ( $allowed_proto && @$allowed_proto ) {
		my @proto_new;
		foreach my $ap ( @$allowed_proto ) {
			my $p = first { $ap eq $_ } @proto;
			push @proto_new,$p if $p;
		}
		@proto = @proto_new;
		@proto or do {
			DEBUG( 50,"no protocols allowed for $uri" );
			return invoke_callback( $callback, ENOPROTOOPT ); # no proto available
		};
	}

	$dst_addr ||= [];
	$allowed_legs ||= [ $self->get_legs ];
	if ( @$legs ) {
		my %allowed = map { $_ => 1 } @$legs;
		@$allowed_legs = grep { $allowed{$_} } @$allowed_legs;
	}
	@$allowed_legs or do {
		DEBUG( 50,"no legs allowed for '$uri'" );
		return invoke_callback($callback, EHOSTUNREACH );
	};

	my $ip_addr;
	if ( $domain =~m{^(\d+\.\d+\.\d+\.\d+)(?::(\d+))?$} ) {
		# if domain part of URI is IPv4[:port]
		$default_port = $2 if defined $2;
		$ip_addr = $1;
		# e.g. 10.0.3.4 should match *.3.0.10.in-addr.arpa
		$domain = join( '.', reverse split( m{\.},$ip_addr )).'.in-addr.arpa';
	} else {
		$domain =~s{\.*(?::(\d+))?$}{}; # remove trailing dots + port
		$default_port = $1 if defined $1;
	}
	DEBUG( 100,"domain=$domain" );

	# do we have a fixed proxy for the domain or upper domain?
	if ( ! @$dst_addr ) {
		my $d2p = $self->{domain2proxy};
		if ( $d2p && %$d2p ) {
			my $dom = $domain;
			my $addr = $d2p->{$dom}; # exact match
			while ( ! $addr) {
				$dom =~s{^[^\.]+\.}{} or last;
				$addr = $d2p->{ "*.$dom" };
			}
			$addr ||= $d2p->{ $dom = '*'}; # catch-all
			if ( $addr ) {
				DEBUG( 50,"setting dst_addr from domain specific proxy for domain $dom" );
				@$dst_addr = @$addr;
			}
		}
	}

	# do we have a global outgoing proxy?
	if ( !@$dst_addr
		&& ( my $addr = $self->{outgoing_proxy} )) {
		# if we have a fixed outgoing proxy use it
		DEBUG( 50,"setting dst_addr+leg to $addr from outgoing_proxy" );
		@$dst_addr = ( $addr );
	}

	# is it an IP address?
	if ( !@$dst_addr && $ip_addr ) {
		DEBUG( 50,"setting dst_addr from URI because IP address given" );
		@$dst_addr = ( $ip_addr );
	}

	# is param maddr set?
	if ( my $ip = $param->{maddr} ) {
		@$dst_addr = ( $ip )
			if $ip =~m{^[\d\.]+$} && eval { inet_aton($ip) };
	}

	# entries in form [ prio,proto,ip,port ]
	my @resp;
	foreach my $addr ( @$dst_addr ) {
		if ( ref($addr)) {
			push @resp,$addr; # right format: see domain2proxy
		} else {
			$addr =~m{^(?:(udp|tcp):)?([^:]+)(?::(\d+))?$} || next;
			my $host = $2;
			my $proto = $1 ? [ $1 ] : \@proto;
			my $port = $3 ? $3 : $default_port;
			push @resp, map { [ -1,$_,$host,$port ] } @$proto;
		}
	}

	# should we use a fixed transport?
	if ( my $proto = $param->{transport} ) {
		@resp = grep { lc($_->[1]) eq lc($proto) } @resp;
	}

	my @param = ( $dst_addr,$legs,$allowed_legs,$default_port,$callback );
	return __resolve_uri_final( @param,0,\@resp ) if @resp;

	# If no fixed mapping DNS needs to be used

	# XXXX no full support for RFC3263, eg we don't support NAPTR
	# but query instead directly for _sip._udp.domain.. like in
	# RFC2543 specified

	return $self->dns_domain2srv(
		$domain, \@proto, $sip_proto,
		[ \&__resolve_uri_final, @param ]
	);
}

sub __resolve_uri_final {

	my ($dst_addr,$legs,$allowed_legs,$default_port,$callback,$error,$resp) = @_;

	DEBUG_DUMP( 100,$resp );
	return invoke_callback( $callback,EHOSTUNREACH )
		unless $resp && @$resp;

	# for A records we got no port, use default_port
	$_->[3] ||= $default_port for(@$resp);

	# sort by prio
	# FIXME: can contradict order in @proto
	@$resp = sort { $a->[0] <=> $b->[0] } @$resp;

	@$dst_addr = ();
	@$legs = ();
	foreach my $r ( @$resp ) {
		my $leg = first { $_->can_deliver_to(
			proto => $r->[1],
			addr  => $r->[2],
			port  => $r->[3]
		)} @$allowed_legs;

		if ( $leg ) {
			push @$dst_addr, "$r->[1]:$r->[2]:$r->[3]";
			push @$legs,$leg;
		} else {
			DEBUG( 50,"no leg for $r->[1]:$r->[2]:$r->[3]" );
		}
	}

	return invoke_callback( $callback, EHOSTUNREACH ) if !@$dst_addr;
	invoke_callback( $callback );
}


sub _find_leg4addr {
	my Net::SIP::Dispatcher $self = shift;
	my $dst_addr = shift;
	my ($proto,$ip) = $dst_addr =~m{^(?:(tcp|udp):)?([^:]+)};
	my @legs;
	foreach my $leg (@{ $self->{legs} }) {
		push @legs,$leg if $leg->can_deliver_to( addr => $ip, proto => $proto );
	}
	return @legs;
}

###########################################################################
# resolve hostname to IP using DNS
# FIXME: should work asynchronously
# Args: ($self,$host,$callback)
#   $host: hostname or hash with hostname as keys
#   $callback: gets called with (EINVAL) or (undef,result) once finished
#     result is IP for single hosts or the input hash ref where the
#     IPs are filled in as values
# Returns: NONE
###########################################################################
sub dns_host2ip {
	my Net::SIP::Dispatcher $self = shift;
	my ($host,$callback) = @_;
	if ( ref($host)) {
		my $err;
		foreach ( keys %$host ) {
			if ( my $addr = gethostbyname( $_ )) {
				$host->{$_} = inet_ntoa($addr);
			} else {
				$err = EINVAL;
			}
		}
		invoke_callback( $callback, $err,$host );
	} else {
		my $addr = gethostbyname( $host );
		invoke_callback( $callback, $addr ? ( undef,inet_ntoa($addr) ) : ( $? ));
	}
}

###########################################################################
# get SRV records using DNS
# FIXME: should work asynchronously
# Args: ($self,$domain,$proto,$sip_proto,$callback)
#   $domain: domain for SRV query
#   $proto: which protocols to check
#   $sip_proto: sip|sips
#   $callback: gets called with result once finished
#      result is \@list of [ prio,proto,name,port ]
# Returns: NONE
###########################################################################
sub dns_domain2srv {
	my Net::SIP::Dispatcher $self = shift;
	my ($domain,$protos,$sip_proto,$callback) = @_;

	# FIXME: don't do blocking DNS queries
	my $dns = Net::DNS::Resolver->new;

	# Try to get SRV records for _sip._udp.domain or _sip._tcp.domain
	my (@resp,%addr2ip);
	foreach my $proto ( @$protos ) {
		if ( my $q = $dns->query( '_'.$sip_proto.'._'.$proto.'.'.$domain,'SRV' )) {
			foreach my $rr ( $q->answer ) {
				if ( $rr->type eq 'A' ) {
					push @{ $addr2ip{$rr->name} }, $rr->address;
				} elsif ( $rr->type eq 'SRV' ) {
					push @resp,[ $rr->priority, $proto,$rr->target,$rr->port ]
				}
			}
		}
	}

	# name to addr based on additional records in DNS answer
	my @resp_resolved;
	for my $r (@resp) {
		if ( my $addr = $addr2ip{ $r->[2] } ) {
			for (@$addr) {
				my @cp = @$r;
				$cp[2] = $_;
				push @resp_resolved, \@cp;
			}
		} else {
			# either already IP or no additional data for resolving -> later
			my @cp = @$r;
			# XXX fixme blocking DNS lookup
			my $ipn = gethostbyname( $r->[2] ) or do {
				DEBUG( 1,"cannot resolve $r->[2]" );
				next;
			};
			$cp[2] = inet_ntoa($ipn);
			push @resp_resolved, \@cp;
		}
	}
	@resp = @resp_resolved;

	# if no SRV records try to resolve address directly
	unless (@resp) {
		# try addr directly
		my $default_port = $sip_proto eq 'sips' ? 5061:5060;
		if ( my $q = $dns->query( $domain,'A' )) {
			foreach my $rr ($q->answer ) {
				$rr->type eq 'A' || next;
				# XXX fixme, check that name in response corresponds to query
				# (beware of CNAMEs!)
				push @resp,map {
					[ -1, $_ , $rr->address,$default_port ]
				} @$protos;
			}
		}
	}
	my $error = @resp ? 0 : EINVAL;
	invoke_callback( $callback,$error,\@resp );
}

###########################################################################
# Net::SIP::Dispatcher::Packet
# Container for Queue entries in Net::SIP::Dispatchers queue
###########################################################################
package Net::SIP::Dispatcher::Packet;
use fields (
	'id',           # transaction id, used for canceling delivery if response came in
	'callid',       # callid, used for canceling all deliveries for this call
	'packet',       # the packet which nees to be delivered
	'dst_addr',     # to which adress the packet gets delivered, is array-ref because
					# the DNS/SRV lookup might return multiple addresses and protocols
	'leg',          # through which leg the packet gets delivered, same number
					# of items like dst_addr
	'retransmits',  # array of retransmit time stamps, if undef no retransmit will be
					# done, if [] no more retransmits can be done (trigger ETIMEDOUT)
					# the last element in this array will not used for retransmit, but
					# is the timestamp, when the delivery fails permanently
	'callback',     # callback for DSN (success, ETIMEDOUT...)
	'proto',        # list of possible protocols, default tcp and udp for sip:
);

use Net::SIP::Debug;
use Net::SIP::Util 'invoke_callback';

###########################################################################
# create new Dispatcher::Packet
# Args: ($class,%args)
#  %args: hash with values according to fields
#    for response packets leg and dst_addr must be set
# Returns: $self
###########################################################################
sub new {
	my ($class,%args) = @_;
	my $now = delete $args{now};

	my $self = fields::new( $class );
	%$self = %args;
	$self->{id} ||= $self->{packet}->tid;
	$self->{callid} ||= $self->{packet}->callid;

	if ( my $addr = $self->{dst_addr} ) {
		$self->{dst_addr} = [ $addr ] if !ref($addr)
	}
	if ( my $leg = $self->{leg} ) {
		$self->{leg} = [ $leg ] if UNIVERSAL::can( $leg,'deliver' );
	}

	$self->{dst_addr} ||= [];
	$self->{leg} ||= [];

	# figure out retransmit times
	my $p = $self->{packet} || die "no packet for delivery";
	if ( $p->is_response ) {
		unless ( $self->{leg} && $self->{dst_addr} ) {
			die "Response packet needs leg and dst_addr"
		}
	}
	return $self;
}

###########################################################################
# prepare retransmit infos if dispatcher handles retransmits itself
# Args: ($self;$now)
#   $now: current time
# Returns: NONE
###########################################################################
sub prepare_retransmits {
	my Net::SIP::Dispatcher::Packet $self = shift;
	my $now = shift;
	my $p = $self->{packet};

	# RFC3261, 17.1.1.2 (final response to INVITE) -> T1=0.5, T2=4
	# RFC3261, 17.1.2.2 (non-INVITE requests)      -> T1=0.5, T2=4
	# RFC3261, 17.1.1.2 (INVITE request)           -> T1=0.5, T2=undef
	# no retransmit -> T1=undef

	my ($t1,$t2);
	if ( $p->is_response ) {
		if ( $p->code > 100 && $p->cseq =~m{\sINVITE$} ) {
			# this is a final response to an INVITE
			# this is the only type of response which gets retransmitted
			# (until I get an ACK)
			($t1,$t2) = (0.500,4);
		}
	} elsif ( $p->method eq 'INVITE' ) {
		# INVITE request
		($t1,$t2) = (0.500,undef);
	} elsif ( $p->method eq 'ACK' ) {
		# no retransmit of ACKs
	} else {
		# non-INVITE request
		($t1,$t2) = (0.500,4);
	}

	# no retransmits?
	$t1 || return;

	$now ||= time();
	my $expire = $now + 64*$t1;
	my $to = $t1;
	my $rtm = $now + $to;

	my @retransmits;
	while ( $rtm < $expire ) {
		push @retransmits, $rtm;
		$to *= 2;
		$to = $t2 if $t2 && $to>$t2;
		$rtm += $to
	}
	DEBUG( 100,"retransmits $now + ".join( " ", map { $_ - $now } @retransmits ));
	$self->{retransmits} = \@retransmits;
}



###########################################################################
# use next dst_addr (eg if previous failed)
# Args: $self
# Returns: $addr
#   $addr: new address it will use or undef if no more addresses available
###########################################################################
sub use_next_dstaddr {
	my Net::SIP::Dispatcher::Packet $self = shift;
	my $addr = $self->{dst_addr} || return;
	shift(@$addr);
	my $leg = $self->{leg} || return;
	shift(@$leg);
	return @$addr && $addr->[0];
}

###########################################################################
# trigger callback to upper layer
# Args: ($self;$errno)
#  $errno: Errno
# Returns: $callback_done
#  $callback_done: true if callback was triggered, if no callback existed
#    returns false
###########################################################################
sub trigger_callback {
	my Net::SIP::Dispatcher::Packet $self = shift;
	my $error = shift;
	my $cb = $self->{callback} || return;
	invoke_callback( $cb,$error,$self);
	return 1;
}

###########################################################################
# return transaction id of packet
# Args: $self
# Returns: $tid
###########################################################################
sub tid {
	my Net::SIP::Dispatcher::Packet $self = shift;
	return $self->{packet}->tid;
}
1;