Net-SIP-0.822/0000755000175100017510000000000013552315100011427 5ustar workworkNet-SIP-0.822/lib/0000755000175100017510000000000013552315100012175 5ustar workworkNet-SIP-0.822/lib/Net/0000755000175100017510000000000013552315100012723 5ustar workworkNet-SIP-0.822/lib/Net/SIP/0000755000175100017510000000000013552315100013356 5ustar workworkNet-SIP-0.822/lib/Net/SIP/Blocker.pm0000644000175100017510000000423012271422677015313 0ustar workwork########################################################################### # package Net::SIP::Blocker ########################################################################### use strict; use warnings; package Net::SIP::Blocker; use fields qw( dispatcher block ); use Carp 'croak'; use Net::SIP::Debug; ########################################################################### # creates new Blocker object # Args: ($class,%args) # %args # block: \%hash where the blocked method is the key and its value # is a number with three digits with optional message # e.g. { 'SUBSCRIBE' => 405 } # dispatcher: the Net::SIP::Dispatcher object # Returns: $self ########################################################################### sub new { my ($class,%args) = @_; my $self = fields::new( $class ); my $map = delete $args{block} or croak("no mapping between method and code"); while (my ($method,$code) = each %$map) { $method = uc($method); ($code, my $msg) = $code =~m{^(\d\d\d)(?:\s+(.+))?$} or croak("block code for $method must be DDD [text]"); $self->{block}{$method} = defined($msg) ? [$code,$msg]:[$code]; } $self->{dispatcher} = delete $args{dispatcher} or croak('no dispatcher given'); return $self; } ########################################################################### # Blocks methods not wanted and sends a response back over the same leg # with the Error-Message of the block_code # Args: ($self,$packet,$leg,$from) # args as usual for sub receive # Returns: block_code | NONE ########################################################################### sub receive { my Net::SIP::Blocker $self = shift; my ($packet,$leg,$from) = @_; $packet->is_request or return; my $method = $packet->method; if ( $method eq 'ACK' and my $block = $self->{block}{INVITE} ) { $self->{dispatcher}->cancel_delivery($packet->tid); return $block->[0]; } my $block = $self->{block}{$method} or return; DEBUG( 10,"block $method with code @$block" ); $self->{dispatcher}->deliver( $packet->create_response(@$block), leg => $leg, dst_addr => $from ); return $block->[0] } 1; Net-SIP-0.822/lib/Net/SIP/Util.pm0000644000175100017510000006044513535437045014660 0ustar workwork ########################################################################### # Net::SIP::Util # various functions for helping in SIP programs ########################################################################### use strict; use warnings; package Net::SIP::Util; use Digest::MD5 'md5_hex'; use Socket 1.95 qw( inet_ntop inet_pton AF_INET unpack_sockaddr_in pack_sockaddr_in getaddrinfo ); use Net::SIP::Debug; use Carp qw(confess croak); use base 'Exporter'; BEGIN { my $mod6 = ''; if (eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.31); Socket->import('AF_INET6'); AF_INET6(); }) { $mod6 = 'IO::Socket::IP'; *INETSOCK = sub { return IO::Socket::IP->new(@_) if @_ == 1; # Hack to work around the problem that IO::Socket::IP defaults to # AI_ADDRCONFIG which creates problems if we have only the loopback # interface. If we already know the family this flag is more harmful # then useful. my %args = @_; $args{GetAddrInfoFlags} = 0 if ! defined $args{GetAddrInfoFlags} and $args{Domain} || $args{Family}; return IO::Socket::IP->new(%args); }; } elsif (eval { require IO::Socket::INET6; IO::Socket::INET6->VERSION(2.62); Socket->import('AF_INET6'); AF_INET6(); }) { $mod6 = 'IO::Socket::INET6'; *INETSOCK = sub { return IO::Socket::INET6->new(@_) if @_ == 1; my %args = @_; $args{Domain} = delete $args{Family} if exists $args{Family}; return IO::Socket::INET6->new(%args); }; } else { *INETSOCK = sub { return IO::Socket::INET->new(@_) }; no warnings 'redefine'; # Since value differs between platforms we set it to something that # should not collide with AF_INET and maybe will even cause inet_ntop # etc to croak. In any case this will only be used if CAN_IPV6 is false # because otherwise we have the correct value from Socket. *AF_INET6 = sub() { -1 }; } *CAN_IPV6 = $mod6 ? sub() { 1 } : sub() { 0 }; Socket->import(qw(unpack_sockaddr_in6 pack_sockaddr_in6)) if $mod6; } our @EXPORT = qw(INETSOCK); our @EXPORT_OK = qw( sip_hdrval2parts sip_parts2hdrval sip_uri2parts sip_parts2uri sip_uri_eq sip_uri2sockinfo sip_sockinfo2uri laddr4dst create_socket_to create_rtp_sockets ip_string2parts ip_parts2string ip_parts2sockaddr ip_sockaddr2parts ip_sockaddr2string ip_is_v4 ip_is_v6 ip_is_v46 ip_ptr ip_canonical hostname2ip CAN_IPV6 invoke_callback ); our %EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); our $RTP_MIN_PORT = 2000; our $RTP_MAX_PORT = 12000; ########################################################################### # creates hash from header val, e.g. # 'Digest method="md5",qop="auth",...','www-authenticate' will result in # ( 'Digest', { method => md5, qop => auth,... } ) # Args: ($key,$val) # $key: normalized key (lowercase, long) # $val: value # Returns: ( $data,\%parameter ) # $data: initial data # %parameter: additional parameter ########################################################################### my %delimiter = ( 'www-authenticate' => ',', 'proxy-authenticate' => ',', 'authorization' => ',', 'proxy-authorization' => ',', ); sub sip_hdrval2parts { croak( "usage: sip_hdrval2parts( key => val )" ) if @_!=2; my ($key,$v) = @_; return if !defined($v); my $delim = $delimiter{$key} || ';'; # split on delimiter (but not if quoted) my @v = (''); my $quoted = 0; my $bracket = 0; while (1) { if ( $v =~m{\G(.*?)([\\"<>$delim])}gc ) { if ( $2 eq "\\" ) { $v[-1].=$1.$2.substr( $v,pos($v),1 ); pos($v)++; } elsif ( $2 eq '"' ) { $v[-1].=$1.$2; $quoted = !$quoted if ! $bracket; } elsif ( $2 eq '<' ) { $v[-1].=$1.$2; $bracket = 1 if ! $bracket && ! $quoted; } elsif ( $2 eq '>' ) { $v[-1].=$1.$2; $bracket = 0 if $bracket && ! $quoted; } elsif ( $2 eq $delim ) { # next item if not quoted if ( ! $quoted && ! $bracket ) { ( $v[-1].=$1 ) =~s{\s+$}{}; # strip trailing space push @v,'' ; $v =~m{\G\s+}gc; # skip space after $delim } else { $v[-1].=$1.$2 } } } else { # add rest to last from @v $v[-1].= substr($v,pos($v)||0 ); last; } } # with delimiter ',' it starts 'Digest realm=...' so $v[0] # contains method and first parameter my $data = shift(@v); if ( $delim eq ',' ) { $data =~s{^(\S+)\s*(.*)}{$1}; unshift @v,$2; } # rest will be interpreted as parameters with key|key=value my %hash; foreach my $vv (@v) { my ($key,$value) = split( m{\s*=\s*},$vv,2 ); if ( defined($value) ) { $value =~s{^"(.*)"$}{$1}; # unquote # TODO Q: what's the meaning of "\%04", e.g. is it # '%04' or "\\\004" ?? $value =~s{\\(.)}{$1}sg; # unescape backslashes $value =~s{%([a-fA-F][a-fA-F])}{ chr(hex($1)) }esg; # resolve uri encoding } $hash{lc($key)} = $value; } return ($data,\%hash); } ########################################################################### # reverse to sip_hdrval2parts # Args: ($key,$data,\%parameter) # $key: normalized key (lowercase, long) # $data: initial data # %parameter: additional parameter # Returns: $val # $val: value ########################################################################### sub sip_parts2hdrval { my ($key,$data,$param) = @_; my $delim = $delimiter{$key} || ';'; my $val = $data; # FIXME: need to escape $data? for my $k ( sort keys %$param ) { $val .= $delim.$k; my $v = $param->{$k}; if ( defined $v ) { # escape special chars $v =~s{([%\r\n\t"[:^print:]])}{ sprintf "%%%02x",ord($1) }esg; $v = '"'.$v.'"' if $v =~m{\s|$delim}; $val .= '='.$v } } return $val; } ########################################################################### # extract parts from SIP URI # Args: $uri # Returns: $domain || ($domain,$user,$proto,$param,$data) # $domain: SIP domain maybe with port # $user: user part # $proto: 'sip'|'sips' # $param: hashref with params, e.g { transport => 'udp',... } # $data: full part before any params ########################################################################### sub sip_uri2parts { my $uri = shift; $uri = $1 if $uri =~m{<([^>]+)>\s*$}; my ($data,$param) = sip_hdrval2parts( uri => $uri ); if ( $data =~m{^ (?: (sips?) : )? (?: ([^\s\@]*) \@ )? ( \[ [^\]\s]+ \] ( : \w+)? # [ipv46_or_host]:port | [^:\s]+ ( : \w+)? # ipv4_or_host:port | (?:[a-f\d]*:){2}[a-f\d\.:]* # ipv6 ) $}ix ) { my ($proto,$user,$domain) = ($1,$2,$3); $domain = lc($domain); $proto ||= 'sip'; return wantarray ? ($domain,$user,lc($proto),$param,$data) : $domain } else { return; } } ########################################################################### # reverse to sip_uri2parts, e.g. construct SIP URI # Args: ($domain,$user,$proto,$param) # $domain: SIP domain maybe with port or [host,port,?family] # $user: user part # $proto: 'sip'|'sips' - defaults to 'sip' # $param: hashref with params, e.g { transport => 'udp',... } # Args: $uri ########################################################################### sub sip_parts2uri { my ($domain,$user,$proto,$param) = @_; my $uri = sip_parts2hdrval('uri', ($proto || 'sip'). ':' . ($user ? $user.'@' : '') . (ref($domain) ? ip_parts2string(@$domain) : $domain), $param ); return $param && %$param ? "<$uri>" : $uri; } ########################################################################### # Extract the parts from a URI which are relevant for creating the socket, i.e # sips:host:port # sip:host;transport=TCP # Args: $uri,?$opaque # $uri: SIP URI # $opaque: don't enforce that host part of URI looks like hostname or IP # Returns: ($proto,$host,$port,$family) # $proto: udp|tcp|tls|undef # $host: ip or hostname from URI # $port: port from URI # $family: family matching $host, i.e. AF_INET|AF_INET6|undef ########################################################################### sub sip_uri2sockinfo { my ($domain,undef,$proto,$param) = sip_uri2parts(shift()) or return; $proto = ($proto && $proto eq 'sips') ? 'tls' : # sips -> tls $param->{transport} ? lc($param->{transport}) : # transport -> tcp|udp undef; # not restricted return ($proto, ip_string2parts($domain, shift())); } ########################################################################### # Reverse to sip_uri2sockinfo # Args: (\%hash|$proto,$host,$port,$family) # $proto: udp|tcp|tls|undef # $host: ip or hostname from URI # $port: port from URI # $family: family matching $host, i.e. AF_INET|AF_INET6|undef # %hash: hash with keys proto, host, port, family # Returns: $uri ########################################################################### sub sip_sockinfo2uri { my ($proto,$host,$port,$family) = ref($_[0]) ? @{$_[0]}{qw(proto host port family)} : @_; return sip_parts2uri( ip_parts2string($host,$port,$family), undef, !defined $proto ? ('sip', {}) : $proto eq 'tls' ? ('sips', {}) : $proto eq 'tcp' ? ('sip', { transport => 'TCP' }) : $proto eq 'udp' ? ('sip', {}) : die "invalid proto: '$proto'" ) } ########################################################################### # returns true if two URIs are the same # Args: $uri1,$uri2 # Returns: true if both URI point to same address ########################################################################### sub sip_uri_eq { my ($uri1,$uri2) = @_; return 1 if $uri1 eq $uri2; # shortcut for common case my ($d1,$u1,$p1) = sip_uri2parts($uri1); my ($d2,$u2,$p2) = sip_uri2parts($uri2); my $port1 = $d1 =~s{:(\d+)$|\[(\d+)\]$}{} ? $1||$2 : $p1 eq 'sips' ? 5061 : 5060; my $port2 = $d2 =~s{:(\d+)$|\[(\d+)\]$}{} ? $1||$2 : $p2 eq 'sips' ? 5061 : 5060; return lc($d1) eq lc($d2) && $port1 == $port2 && ( defined($u1) ? defined($u2) && $u1 eq $u2 : ! defined($u2)) && $p1 eq $p2; } ########################################################################### # fid out local address which is used when connecting to destination # Args: ($dst,@src) # $dst: target IP (or ip:port) # @src: optional list of source IP to try, if not given will use any source # Return: $ip|($ip,$family) - source IP used when reaching destination # Comment: # A UDP socket will be created and connected and then the local address # read from the socket. It is expected that the OS kernel will fill in # the local address when connecting even though no packets are actually # send to the peer ########################################################################### sub laddr4dst { my ($dst,@src) = @_; my ($addr, $port, $fam) = ip_string2parts($dst); $fam or return; # no IP destination for my $src (@src ? @src : (undef)) { my $sock = INETSOCK( Proto => 'udp', Family => $fam, PeerAddr => $addr, PeerPort => $port || 5060, $src ? (LocalAddr => $src) : (), ) or next; my @parts = ip_sockaddr2parts(getsockname($sock)); return wantarray ? @parts[0,2] : $parts[0]; } return; # no route } ########################################################################### # create socket preferable on port 5060 from which one might reach the given IP # Args: ($dst_addr;$proto) # $dst_addr: the adress which must be reachable from this socket # $proto: udp|tcp|tls, default udp # Returns: ($sock,$ip_port) || $sock || () # $sock: the created socket # $ip_port: ip:port of socket, only given if called in array context # Comment: the IP it needs to come from works by creating a udp socket # to this host and figuring out it's IP by calling getsockname. Then it # tries to create a socket on this IP using port 5060/5061 and if this does # not work it tries the port 5062..5100 and if this does not work too # it let the system use a random port # If creating of socket fails it returns () and $! is set ########################################################################### sub create_socket_to { my ($dst_addr,$proto) = @_; $proto ||= 'udp'; my ($laddr,$fam) = laddr4dst($dst_addr); DEBUG( "Local IP is $laddr" ); # Bind to this IP # First try port 5060..5100, if they are all used use any port # I get from the system for my $p ( $proto eq 'tls' ? 5061:5060, 5062..5100, 0 ) { $DEBUG && DEBUG( "try to listen on %s", ip_parts2string($laddr,$p,$fam)); my $sock = INETSOCK( Family => $fam, LocalAddr => $laddr, $p ? (LocalPort => $p) : (), Proto => $proto eq 'tls' ? 'tcp' : $proto, ) or next; my $port = $p || (ip_sockaddr2parts(getsockname($sock)))[1]; $DEBUG && DEBUG("listen on %s",ip_parts2string($laddr,$port,$fam)); return $sock if ! wantarray; return ($sock,ip_parts2string($laddr,$port,$fam)); } die "even binding to port 0 failed: $!"; } ########################################################################### # create RTP/RTCP sockets # Args: ($laddr;$range,$min,$max,$tries) # $laddr: local addr # $range: how many sockets, 2 if not defined # $min: minimal port number, default $RTP_MIN_PORT # $max: maximal port number, default 10000 more than $min # or $RTP_MAX_PORT if $min not given # $tries: how many tries, default 100 # Returns: ($port,$rtp_sock,$rtcp_sock,@more_socks) # $port: port of RTP socket, port for RTCP is port+1 # $rtp_sock: socket for RTP data # $rtcp_sock: socket for RTCP data # @more_socks: more sockets (if range >2) ########################################################################### sub create_rtp_sockets { my ($laddr,$range,$min,$max,$tries) = @_; $range ||= 2; if ( ! $min ) { $min = $RTP_MIN_PORT; $max ||= $RTP_MAX_PORT; } else { $max ||= $min+10000; } $min += $min%2; # make even $tries ||= 1000; my $diff2 = int(($max-$min)/2) - $range +1; my (@socks,$port); my $fam = (ip_string2parts($laddr))[2]; while ( $tries-- >0 ) { last if @socks == $range; close $_ for @socks; @socks = (); $port = 2*int(rand($diff2)) + $min; for( my $i=0;$i<$range;$i++ ) { push @socks, INETSOCK( Family => $fam, Proto => 'udp', LocalAddr => $laddr, LocalPort => $port + $i, ) || last; } } return if @socks != $range; # failed return ($port,@socks); } ########################################################################### # helper to call callback, set variable.. # Args: ($cb;@args) # $cb: callback # @args: additional args for callback # Returns: $rv # $rv: return value of callback # Comment: # callback can be # - code ref: will be called with $cb->(@args) # - object with method run, will be called with $cb->run(@args) # - array-ref with [ \&sub,@myarg ], will be called with $sub->(@myarg,@args) # - scalar ref: the scalar will be set to $args[0] if @args, otherwise true # - regex: returns true if anything in @args matches regex ########################################################################### sub invoke_callback { my ($cb,@more_args) = @_; if ( UNIVERSAL::isa( $cb,'CODE' )) { # anon sub return $cb->(@more_args) } elsif ( my $sub = UNIVERSAL::can( $cb,'run' )) { # Callback object return $sub->($cb,@more_args ); } elsif ( UNIVERSAL::isa( $cb,'ARRAY' )) { my ($sub,@args) = @$cb; # [ \&sub,@arg ] return $sub->( @args,@more_args ); } elsif ( UNIVERSAL::isa( $cb,'Regexp' )) { @more_args or return; for(@more_args) { return 1 if m{$cb} } return 0; } elsif ( UNIVERSAL::isa( $cb,'SCALAR' ) || UNIVERSAL::isa( $cb,'REF' )) { # scalar ref, set to true $$cb = @more_args ? shift(@more_args) : 1; return $$cb; } elsif ( $cb ) { confess "unknown handler $cb"; } } ########################################################################### # split string into host/ip, port and detect family (IPv4 or IPv6) # Args: $addr;$opaque # $addr: ip_or_host, ipv4_or_host:port, [ip_or_host]:port # $opaque: optional argument, if true it will not enforce valid syntax # for the hostname and will not return canonicalized data # Returns: (\%hash|$host,$port,$family) # $host: canonicalized IP address or hostname # $port: the port or undef if no port was given in string # $family: AF_INET or AF_INET6 or undef (hostname not IP given) # %hash: hash with addr, port, family - used if !wantarray ########################################################################### sub ip_string2parts { my ($addr,$opaque) = @_; my ($host,$port,$family); if ($addr =~m{:[^:\s]*(:)?}) { if (!$1) { # (ipv4|host):port ($host,$port) = split(':',$addr,2); $family = AF_INET; } elsif ($addr =~m{^\[(?:(.*:.*)|([^:]*))\](?::(\w+))?\z}) { $port = $3; ($host,$family) = $1 ? ($1, AF_INET6) # [ipv6](:port)? : ($2, AF_INET); # [ipv4|host](:port)? } else { # ipv6 ($host,$family) = ($addr, AF_INET6); } } else { # ipv4|host ($host,$family) = ($addr, AF_INET); } # we now have: # AF_INET6 if it contains a ':', i.e. either valid IPv6 or smthg invalid # AF_INET otherwise, i.e. IPv4 or hostname or smthg invalid # check if this is an IP address from the expected family if ($addr = inet_pton($family,$host)) { # valid IP address $addr = $opaque ? $host : inet_ntop($family, $addr); # canonicalized form } elsif ($opaque) { # not a valid IP address - pass through because opaque $family = $addr = undef; } elsif ($host =~m{^[a-z\d\-\_]+(?:\.[a-z\d\-\_]+)*\.?\z}) { # not a valid IP address but valid hostname $family = $addr = undef; } else { # neither IP nor valid hostname Carp::confess("invalid hostname '$host' in '$_[0]'"); die("invalid hostname '$host' in '$_[0]'"); } # make sure that it looks like a valid hostname and return it lower case $host = lc($host) if ! $opaque; return ($host,$port,$family) if wantarray; return { host => $host, addr => $addr, port => $port, family => $family }; } ########################################################################### # concat ip/host and port to string, i.e. reverse to ip_string2parts # Args: ($host;$port,$family,$ipv6_brackets) # $host: the IP address or hostname # $port: optional port # $family: optional, will be detected from $host if not given # $ipv6_brackets: optional, results in [ipv6] if true and no port given # alternative Args: (\%hash,$ipv6_brackets) # %hash: hash containing addr|host, port and family # if opt default_port is given will treat port as 0 if default # if opt use_host is true will prefer host instead of addr # Returns: $addr # $addr: ip_or_host, ipv4_or_host:port, [ipv6]:port, # [ipv6] (if ipv6_brackets) ########################################################################### sub ip_parts2string { my ($host,$port,$fam,$ipv6_brackets); if (ref($_[0])) { (my $hash,$ipv6_brackets) = @_; $port = $hash->{port}; $fam = $hash->{family}; $host = $hash->{addr} || $hash->{host}; if (exists $hash->{use_host} && $hash->{use_host} && $hash->{host} && $fam && $hash->{host} ne $hash->{addr}) { # use host instead of addr and set family to undef in order to # not put hostname in brackets $host = $hash->{host}; $fam = undef; } if (exists $hash->{default_port} && $port == $hash->{default_port}) { $port = 0; } } else { ($host,$port,$fam,$ipv6_brackets) = @_; } $host = lc($host); return $host if ! $port && !$ipv6_brackets; $fam ||= $host =~m{:} && AF_INET6; $host = "[$host]" if $fam && $fam != AF_INET; return $host if ! $port; return $host.':'.$port; } ########################################################################### # create sockaddr from IP, port (and family) # Args: ($addr,$port;$family) # $addr: the IP address # $port: port # $family: optional, will be detected from $ip if not given # alternative Args: \%hash # %hash: hash with addr, port, family # Returns: $sockaddr ########################################################################### sub ip_parts2sockaddr { my ($addr,$port,$fam); if (ref($_[0])) { $addr = $_[0]->{addr}; $port = $_[0]->{port}; $fam = $_[0]->{family}; } else { ($addr,$port,$fam) = @_; } $fam ||= $addr =~m{:} ? AF_INET6 : AF_INET; if ($fam == AF_INET) { return pack_sockaddr_in($port,inet_pton(AF_INET,$addr)) } elsif (CAN_IPV6) { return pack_sockaddr_in6($port,inet_pton(AF_INET6,$addr)) } else { die "no IPv6 support" } } ########################################################################### # create parts from sockaddr, i.e. reverse to ip_parts2sockaddr # Args: $sockaddr;$family # $sockaddr: sockaddr as returned by getsockname, recvfrom.. # $family: optional family, otherwise guessed based on size of sockaddr # Returns: (\%hash | $ip,$port,$family) # $ip: the IP address # $port: port # $family: AF_INET or AF_INET6 # %hash: hash with host, addr, port, family - if not wantarray ########################################################################### sub ip_sockaddr2parts { my ($sockaddr,$fam) = @_; $fam ||= length($sockaddr)>=24 ? AF_INET6 : AF_INET; die "no IPv6 support" if $fam != AF_INET && !CAN_IPV6; my ($port,$addr) = $fam == AF_INET ? unpack_sockaddr_in($sockaddr) : unpack_sockaddr_in6($sockaddr); $addr = inet_ntop($fam,$addr); return ($addr,$port,$fam) if wantarray; return { host => $addr, addr => $addr, port => $port, family => $fam, }; } ########################################################################### # gets string from sockaddr, i.e. like ip_parts2string(ip_sockaddr2parts(..)) # Args: $sockaddr;$family # $sockaddr: sockaddr as returned by getsockname, recvfrom.. # $family: optional family, otherwise guessed based on size of sockaddr # Returns: $string ########################################################################### sub ip_sockaddr2string { my ($sockaddr,$fam) = @_; $fam ||= length($sockaddr)>=24 ? AF_INET6 : AF_INET; if ($fam == AF_INET) { my ($port,$addr) = unpack_sockaddr_in($sockaddr); return inet_ntop(AF_INET,$addr) . ":$port"; } else { my ($port,$addr) = unpack_sockaddr_in6($sockaddr); return '[' . inet_ntop(AF_INET6,$addr) . "]:$port"; } } ########################################################################### # return name for PTR lookup of given IP address # Args: $ip;$family # $ip: IP address # $family: optional family # Returns: $ptr_name ########################################################################### sub ip_ptr { my ($ip,$family) = @_; $family ||= $ip=~m{:} ? AF_INET6 : AF_INET; if ($family == AF_INET) { return join('.', reverse(unpack("C*",inet_pton(AF_INET,$ip)))) . '.in-addr.arpa'; } else { return join('.', reverse(split('', unpack("H*", inet_pton(AF_INET6,$ip))))) . '.ip6.arpa'; } } ########################################################################### # convert IP address into canonical form suitable for comparison # Args: $ip;$family # $ip: IP address # $family: optional family # Returns: $ip_canonical ########################################################################### sub ip_canonical { my ($ip,$family) = @_; $family ||= $ip=~m{:} ? AF_INET6 : AF_INET; return inet_ntop($family, inet_pton($family, $ip)); } ########################################################################### # get IP addresses for hostname # Args: ($name;$family) # $name: hostname # $family: optional family to restrict result to IPv4/IPv6 # Returns: @ip | $ip - i.e. list of IP or first of the list ########################################################################### sub hostname2ip { my ($name,$family) = @_; $family = AF_INET if ! $family && ! CAN_IPV6; my ($err,@result) = getaddrinfo($name,undef, $family ? ({ family => $family }):() ); return if $err || ! @result; @result = $result[0] if ! wantarray; ($_) = ip_sockaddr2parts($_->{addr},$_->{family}) for @result; return wantarray ? @result : $result[0] } ########################################################################### # check if address is valid IPv4 or IPv6 address # Args: $ip # Returns: true|false ########################################################################### sub ip_is_v4 { inet_pton(AF_INET, $_[0]) } sub ip_is_v6 { inet_pton(AF_INET6, $_[0]) } ########################################################################### # check if address is valid IP address # Args: $ip # Returns: AF_INET|AF_INET6|undef ########################################################################### sub ip_is_v46 { return inet_pton(AF_INET, $_[0]) ? AF_INET : inet_pton(AF_INET6, $_[0]) ? AF_INET6 : undef; } 1; Net-SIP-0.822/lib/Net/SIP/Simple/0000755000175100017510000000000013552315100014607 5ustar workworkNet-SIP-0.822/lib/Net/SIP/Simple/RTP.pod0000644000175100017510000000454412656712670016010 0ustar workwork =head1 NAME Net::SIP::Simple::RTP - simple RTP handling for L =head1 SYNOPSIS my $echo_10 = Net::SIP::Simple->rtp( 'media_recv_echo', 'output.pcmu-8000', 10 ); my $announce = Net::SIP::Simple->rtp( 'media_send_recv', 'announce.pcmu-8000', 2 ); =head1 DESCRIPTION This package handles simple RTP stuff for testing and small applications. It provides methods for receiving PCUM/8000 data and for echoing them back or for sending and receiving PCMU/8000 data. It's used from method B in L. =head1 SUBROUTINES =over 4 =item media_recv_echo ( [ OUTPUT, DELAY ] ) Receives RTP data and echoes them back to the sender. If OUTPUT is given it will be used as the file for saving the received data without the RTP header. OUTPUT might also be a callback which gets the payload as argument. If DELAY is >0 the data will not be echoed back immediately but with a delay of DELAY packets (e.g. with DELAY 10 it will send back the first packet after it received the 10th packet). If DELAY is <0 the data will not be echoed back. If DELAY is not given or equal 0 the data will be echoed back immediately. If no traffic comes in for more then 10 seconds it will hang up the call because of inactivity. =item media_send_recv ( INPUT, [ REPEAT, OUTPUT ] ) Will read data from file INPUT and send them as RTP to peer. It will assume that each data block in INPUT consists of 160 bytes, which is right for PCMU/8000 without RTP header. The RTP header will be added to the data. If it reaches the end of the file it will stop unless REPEAT is given in which case it will repeat the sending REPEAT times (if REPEAT is less 0 it will repeat forever e.g. until the other party hangs up). On stopping it will invoke the callback B from the connection params for the L or if this is not given it will close the call by issuing a BYE. INPUT might also be a callback usable by B in L which returns the data to send. In this case REPEAT is not used. Incoming data will be written to the optional OUTPUT file like in B. The content from OUTPUT has the same format as INPUT or OUTPUT from B. OUTPUT might also be a callback which gets the payload as an argument. If no traffic comes in for more then 10 seconds it will hang up the call because of inactivity. =back Net-SIP-0.822/lib/Net/SIP/Simple/Call.pod0000644000175100017510000003136113370543213016200 0ustar workwork =head1 NAME Net::SIP::Simple::Call - call context for L =head1 SYNOPSIS my $call = $simple->invite(...); $call->reinvite(... ); $call->bye(); =head1 DESCRIPTION This package manages the call context for L, e.g. (re-)invites on existing context etc. =head1 CONSTRUCTOR =over 4 =item new ( CONTROL, CTX, \%ARGS ) Creates a new L object to control a call. Usually called from B in L. CONTROL is the L object managing the calls. CTX is either an existing L or the SIP address of the peer which will be contacted in this call or a hash which can be used to create the context. If no complete context is given missing information will be taken from C<$call> if called as C<$call->new>. %ARGS are used to describe the behavior of the call and will be saved in the object as the connection parameter. The following options are used in the connection parameter and can be given in %ARGS: =over 8 =item leg Specifies which leg should be used for the call (default is first leg in dispatcher). =item sdp_on_ack If given and TRUE it will not send the SDP body on INVITE request, but on ACK. Mainly used for testing behavior of proxies in between the two parties. =item init_media Callback used to initialize media for the connection, see method B in L and L. Callback will be invoked with the call C<$self> and the connection parameter as an argument (as hash reference). =item rtp_param Data for the codec used in the media specified by B and for the initialization of the default SDP data. This is an array reference C<< [pt,size,interval,name] >> where B is the payload type, B is the size of the payload and B the interval in which the RTP packets will be send. B is optional and if given rtpmap and ptime entries will be added to the SDP so that the name is associated with the given payload type. The default is for PCMU/8000: C<< [0,160,160/8000] >>. An alternative would be for example C<< [97,50,0.03,'iLBC/8000'] >> for iLBC. =item sdp L object or argument for constructing this object. If not given it will create an SDP body with one RTP audio connection unless it got first SDP data from the peer in which case it simply matches them. =item sdp_peer Holds the L body send by the peer. Usually not set in the constructor but can be accessed from callbacks. =item media_lsocks Contains a \@list of sockets for each media-line in the SDP. Each item in this list is either a single socket (in case of port range 1) or a \@list of sockets. If B is provided this parameter has to be provided too, e.g. the package will not allocate the sockets described in the SDP packet. =item media_ssocks Sockets used for sending RTP data. If not given the socket for sending RTP is the same as for receiving RTP, unless B is specified. =item asymetric_rtp By default it will send the RTP data from the same port where it listens for the data. If this option is TRUE it will allocate a different port for receiving data. Mainly used for testing behavior of proxies in between the two parties. =item dtmf_methods If a DTMF callback is specified this is treated as a list of supported DTMF methods for receiving DTMF. If not given it defaults to 'rfc2833,audio'. =item recv_bye Callback usable by B in L which will be invoked, when the peer initiated the close of the connection using BYE or CANCEL. Argument for the callback will be a hash reference containing the connection parameter. =item send_bye Callback usable by B in L which will be invoked, when the local side initiated the close of the connection using BYE or CANCEL. Argument for the callback will be a hash reference containing the connection parameter merged with the parameter from the B method. =item clear_sdp If TRUE the keys media_lsocks, media_ssocks, sdp and sdp_peer will be cleared on each new (re)INVITE request, so that it will allocate new sockets for RTP instead of reusing the existing. =item cb_final Callback usable by B in L which will be invoked, when it received the final answer on locally created INVITE requests (e.g. when it established the call by sending the ACK). Callback will be invoked with C<< ( STATUS, SELF, %INFO ) >> where STATUS is either 'OK' or 'FAIL' ('OK' if final response meant success, else 'FINAL'), and %INFO contains more information, like C<< ( packet => packet ) >> for the packet containing the final answer or C<< ( code => response_code ) >> in case failures caused by an unsuccessful response. =item cb_preliminary Callback usable by B in L which will be invoked, when it received a preliminary response on locally created INVITE. Callback will be invoked with C<< ( SELF, CODE, RESPONSE ) >> where CODE is the response code and RESPONSE the L packet. =item cb_established Callback usable by B in L which will be invoked, when it received the final answer on locally created INVITE requests. Callback will be invoked with C<< ( 'OK', SELF ) >>. =item cb_invite Callback usable by B in L which will be invoked, when it received an INVITE request Callback will be invoked with C<< ( SELF, REQUEST ) >> where REQUEST is the L packet for the INVITE. If it returns a Net::SIP::Packet this will be used as response, otherwise a default response with code 200 will be created. =item cb_dtmf Callback usable by B in L which will be invoked, when it received an DTMF event. Callback will be invoked with C<< ( EVENT, DURATION ) >> where EVENT is the event ([0-9A-D*#]) and DURATION the duration in ms. Receiving DTMF needs to be supported by the active RTP handler set with B. All builtin handlers from L are supported. If no RTP handler is set up or if the RTP handler does not support DTMF sending no DTMF will be received without any warning. =item cb_notify Callback usable by B in L which will be invoked, when it received an NOTIFY request Callback will be invoked with C<< ( SELF, REQUEST ) >> where REQUEST is the L packet for the NOTIFY. =item sip_header A reference to a hash with additional SIP headers for the INVITE requests. =item call_on_hold This option causes the next SDP to have 0.0.0.0 as it's address to put this side of the call on hold (will not receive data). This is a one-shot option, e.g. needs to be set with B or within B each time the call should be put on hold. =item ... More parameters may be specified and are accessible from the callbacks. For instance B in L uses a parameter B. See there. =back =back =head1 METHODS =over 4 =item cleanup Will be called to clean up the call. Necessary because callbacks etc can cause cyclic references which need to be broken. Calls B too. Works by invoking all callbacks which are stored as \@list in C<< $self->{call_cleanup} >>. This will called automatically at a clean end of a call (e.g. on BYE or CANCEL, either issued locally or received from the peer). If there is not clean end and one wants to destroy the call unclean one need to call this method manually. =item rtp_cleanup Cleanup of current RTP connection. Works be invoking all callbacks which are stored as \@list in C<< $self->{rtp_cleanup} >> (these callbacks are inserted by L etc). =item get_peer Returns peer of call, see B in L. =item reinvite ( %ARGS ) Creates a INVITE request which causes either the initial SDP session or an update of the SDP session (reinvite). %ARGS will merged with the connection parameter, see description on the constructor. Additionally using B an B as a parameter here would make sense if you want to habe full control about the authorization process. Sets up callback for the connection, which will invoke B once the final response for the INVITE was received and B if this response was successful. If no B callback was given it will wait in the event loop until a final response was received. Only in this case it will also use the param B which specifies the time it will wait for a final response. If no final response came in within this time it will send a CANCEL request for this call to close it. In this case a callback specified with B will be called after the CANCEL was delivered (or delivery failed). Returns the connection context as L object. This method is called within B in L after creating the new L object to create the first SDP session. Changes on the SDP session will be done by calling this method on the L object C<$self>. =item cancel ( %ARGS ) Closes a pending call by sending a CANCEL request. Returns true if call was pending and could be canceled. If %ARGS contains B it will be used as a callback and invoked once it gets the response for the CANCEL (which might be a response packet or a timeout). The rest of %ARGS will be merged with the connection parameter and given as an argument to the B callback (as hash reference). =item bye ( %ARGS ) Closes a call by sending a BYE request. If %ARGS contains B it will be used as a callback and invoked once it gets the response for the BYE (which might be a response packet or a timeout). The rest of %ARGS will be merged with the connection parameter and given as an argument to the B callback (as hash reference). =item request ( METHOD, BODY, %ARGS ) Will create a request with METHOD and BODY and wait for completion. If %ARGS contains B it will be used as a callback and invoked once it gets the response for the request (or timeout). The rest of %ARGS will be used to create request (mostly for request header, see L) =item dtmf ( EVENTS, %ARGS ) Sends DTMF (dial tones) events to peer according to RFC2833 (e.g. as RTP events). EVENTS is a string with the characters 0-9,A-D,*,#. These will be send as DTMF. Any other characters in the string will lead to a pause in sending DTMF (e.g. "123--#" will send "1","2,","3", then add to pauses and then send "#"). In %ARGS one can specify a B in ms (default 100ms) and a callback B which is invoked with first argument 'OK', when all events are send. If no B callback is given the method will return only when all events are send. One can also overwrite the automatic detection of the DTMF method using B in %ARGS. Default is 'rfc2833,audio', with 'rfc2833' only one enforces the use of RTP events, and if the peer does not support it it will croak. Setting to 'audio' will not fail from the client side, but the peer might not look for DTMF inband data if it expects RTP events. Sending DTMF needs to be supported by the active RTP handler set with B. All builtin handlers from L are supported. If no RTP handler is set up or if the RTP handler does not support DTMF sending no DTMF will be received without any warning. =item receive ( ENDPOINT, CTX, ERROR, CODE, PACKET, LEG, FROM ) Will be called from the dispatcher on incoming packets. ENDPOINT is the L object which manages the L CTX calling context for the current call. ERROR is an errno describing the error (and 0|undef if no error). CODE is the numerical code from the packet if a response packet was received. PACKET is the incoming packet, LEG the L where it came in and FROM the C<< "ip:port" >> of the sender. For more details see documentation to B in L. If the incoming packet is a BYE or CANCEL request it will close the call and invoke the B callback. If it is INVITE or ACK it will make sure that the RTP sockets are set up. If receiving an ACK to the current call it will invoke the B callback and also the B callback which cares about setting up the RTP connections (e.g produce and accept RTP traffic). =item set_param ( %ARGS ) Changes param like B, B on the current call. See the constructor. This is useful if call consists of multiple invites with different features. =item get_param ( @KEYS ) Returns values for parameter @KEYS, pendant to B If there is only one key it will return the value as scalar, on multiple keys it returns an array with all values. =back Net-SIP-0.822/lib/Net/SIP/Simple/Call.pm0000644000175100017510000006056413370543213016041 0ustar workwork ########################################################################### # Net::SIP::Simple::Call # manages a call, contains Net::SIP::Endpoint::Context # has hooks for some RTP handling ########################################################################### use strict; use warnings; package Net::SIP::Simple::Call; use base 'Net::SIP::Simple'; use fields qw( call_cleanup rtp_cleanup ctx param ); ########################################################################### # call_cleanup: callbacks for cleaning up call, called at the end # rtp_cleanup: callbacks for cleaning up RTP connections, called # on reINVITEs and at the end # ctx: Net::SIP::Endpoint::Context object for this call # param: various parameter to control behavior # leg: thru which leg the call should be directed (default: first leg) # init_media: initialize handling for media (RTP) data, see # Net::SIP::Simple::RTP # sdp : predefined Net::SIP::SDP or data accepted from NET::SIP::SDP->new # media_lsocks: if sdp is provided the sockets has to be provided too # \@list of sockets for each media, each element in the list is # either the socket (udp) or [ rtp_socket,rtpc_socket ] # sdp_on_ack: send SDP data on ACK, not on INVITE # asymetric_rtp: socket for sending media to peer are not the same as # the sockets, where the media gets received, creates media_ssocks # media_ssocks: sockets used to send media to peer. If not given # and asymetric_rtp is used the sockets will be created, if not given # and not !asymetric_rtp media_lsocks will be used, e.g. symetric RTP # recv_bye: callback or scalar-ref used when call is closed by peer # send_bye: callback or scalar-ref used when call is closed by local side # sdp_peer: Net::SIP::SDP from peer # clear_sdp: ' causes that keys sdp,sdp_peer,media_ssocks and # media_lsocks gets cleared on new invite, so that a new SDP session # need to be established # cb_final: callback which will be called on final response in INVITE # with (status,self,%args) where status is OK|FAIL # cb_preliminary: callback which will be called on preliminary response # in INVITE with (self,code,packet) # cb_established: callback which will be called on receiving ACK in INVITE # with (status,self) where status is OK|FAIL # cb_invite: callback called with ($self,$packet) when INVITE is received # cb_dtmf: callback called with ($event,$duration) when DTMF events # are received, works only with media handling from Net::SIP::Simple::RTP # cb_notify: callback called with ($self,$packet) when NOTIFY is received # sip_header: hashref of SIP headers to add # call_on_hold: one-shot parameter to set local media addr to 0.0.0.0, # will be set to false after use # dtmf_methods: supported DTMF methods for receiving, default 'rfc2833,audio' # rtp_param: [ pt,size,interval,name ] RTP payload type, packet size and interval # between packets managed in Net::SIP::Simple::RTP, default is PCMU/8000, # e.g [ 0,160,160/8000 ] # a name can be added in which case an rtpmap and ptme entry will be created in the # SDP, e.g. [ 97,50,0.03,'iLBC/8000' ] ########################################################################### use Net::SIP::Util qw(:all); use Net::SIP::Debug; use Net::SIP::DTMF 'dtmf_extractor'; use Socket; use Storable 'dclone'; use Carp 'croak'; use Scalar::Util 'weaken'; ########################################################################### # create a new call based on a controller # Args: ($class,$control,$ctx;$param) # $control: Net::SIP::Simple object which controls this call # $ctx: SIP address of peer for new call or NET::SIP::Endpoint::Context # or hashref for constructing NET::SIP::Endpoint::Context # $param: see description of field 'param' # Returns: $self ########################################################################### sub new { my ($class,$control,$ctx,$param) = @_; my $self = fields::new( $class ); %$self = %$control; $self->{ua_cleanup} = []; $ctx = { to => $ctx } if ! ref($ctx); $ctx->{from} ||= $self->{from}; $ctx->{contact} ||= $self->{contact}; $ctx->{auth} ||= $self->{auth}; $ctx->{route} ||= $self->{route}; $self->{ctx} = $ctx; $self->{call_cleanup} = []; $self->{rtp_cleanup} = []; $self->{param} = $param ||= {}; $param->{init_media} ||= $self->rtp( 'media_recv_echo' ); $param->{rtp_param} ||= [ 0,160,160/8000 ]; # PCMU/8000: 50*160 bytes/second $param->{dtmf_events} ||= []; # get added by sub dtmf if (my $cb = delete $param->{cb_cleanup}) { push @{$self->{call_cleanup}}, $cb; } return $self; } ########################################################################### # Cleanups # explicit cleanups might be necessary if callbacks reference back into # the object so that it cannot be cleaned up by simple ref-counting alone ########################################################################### sub cleanup { my Net::SIP::Simple::Call $self = shift; $self->rtp_cleanup; while ( my $cb = shift @{ $self->{call_cleanup} } ) { invoke_callback($cb,$self) } if (my $ctx = delete $self->{ctx}) { $self->{endpoint}->close_context( $ctx ); } $self->{param} = {}; } sub rtp_cleanup { my Net::SIP::Simple::Call $self = shift; while ( my $cb = shift @{ $self->{rtp_cleanup} } ) { invoke_callback($cb,$self) } DEBUG( 100,"done" ); } sub DESTROY { DEBUG( 100,"done" ); } ########################################################################### # return peer of call # Args: $self # Returns: $peer ########################################################################### sub get_peer { my Net::SIP::Simple::Call $self = shift; return $self->{ctx}->peer; } ########################################################################### # set parameter # Args: ($self,%param) # Returns: $self ########################################################################### sub set_param { my Net::SIP::Simple::Call $self = shift; my %args = @_; @{ $self->{param} }{ keys %args } = values %args; return $self; } ########################################################################### # get value for parameter(s) # Args: ($self,@keys) # Returns: @values|$value[0] ########################################################################### sub get_param { my Net::SIP::Simple::Call $self = shift; my @v = @{$self->{param}}{@_}; return wantarray ? @v : $v[0]; } ########################################################################### # (Re-)Invite other party # Args: ($self,%param) # %param: see description of field 'param', gets merged with param # already on object so that the values are valid for future use # Returns: Net::SIP::Endpoint::Context # Comment: # If cb_final callback was not given it will loop until it got a final # response, otherwise it will return immediately ########################################################################### sub reinvite { my Net::SIP::Simple::Call $self = shift; my %args = @_; my $param = $self->{param}; my $clear_sdp = delete $args{clear_sdp}; $clear_sdp = $param->{clear_sdp} if ! defined $clear_sdp; if ( $clear_sdp ) { # clear SDP keys so that a new SDP session will be created @{ $param }{qw( sdp _sdp_saved sdp_peer media_ssocks media_lsocks )} = () } $self->{param} = $param = { %$param, %args } if %args; my $leg = $param->{leg}; if ( ! $leg ) { ($leg) = $self->{dispatcher}->get_legs(); $param->{leg} = $leg; } my $ctx = $self->{ctx}; my $sdp; if ( ! $param->{sdp_on_ack} ) { $self->_setup_local_rtp_socks; $sdp = $param->{sdp} } # predefined callback my $cb = sub { my Net::SIP::Simple::Call $self = shift || return; my ($endpoint,$ctx,$errno,$code,$packet,$leg,$from,$ack) = @_; if ( $errno ) { if (!$code || $code != 487) { $self->error( "Failed with error $errno".( $code ? " code=$code" :"" ) ); } else { # code 487: request was canceled, probably be me -> ignore } invoke_callback( $param->{cb_final}, 'FAIL',$self,errno => $errno, code => $code,packet => $packet ); return; } # new requests in existing call are handled in receive() return $self->receive( @_ ) if $packet->is_request; # response to INVITE # all other responses will not be propagated to this callback my $param = $self->{param}; if ( $code =~m{^1\d\d} ) { # preliminary response, ignore DEBUG(10,"got preliminary response of %s|%s to INVITE",$code,$packet->msg ); invoke_callback( $param->{cb_preliminary},$self,$code,$packet ); return; } elsif ( $code !~m{^2\d\d} ) { DEBUG(10,"got response of %s|%s to INVITE",$code,$packet->msg ); invoke_callback( $param->{cb_final},'FAIL',$self,code => $code, packet => $packet ); return; } # cleanup RTP from last call $self->rtp_cleanup; $self->_setup_peer_rtp_socks( $packet ) || do { invoke_callback( $param->{cb_final},'FAIL',$self ); return; }; if ( $param->{sdp_on_ack} && $ack ) { $self->_setup_local_rtp_socks; $ack->set_body( $param->{sdp} ); } invoke_callback( $param->{cb_final},'OK',$self, packet => $packet ); invoke_callback( $param->{init_media},$self,$param ); }; my $stopvar = 0; $param->{cb_final} ||= \$stopvar; $cb = [ $cb,$self ]; weaken( $cb->[1] ); $self->{ctx} = $self->{endpoint}->invite( $ctx, $cb, $sdp, $param->{sip_header} ? %{ $param->{sip_header} } : () ); if ( $param->{cb_final} == \$stopvar ) { # This callback will be called on timeout or response to cancel which # got send after ring_time was over my $noanswercb; if ( $param->{ring_time} ) { $noanswercb = sub { my Net::SIP::Simple::Call $self = shift || return; my ($endpoint,$ctx,$errno,$code,$packet,$leg,$from,$ack) = @_; $stopvar = 'NOANSWER' ; my $param = $self->{param}; invoke_callback( $param->{cb_noanswer}, 'NOANSWER',$self, errno => $errno,code => $code,packet => $packet ); if ( $code =~ m{^2\d\d} ) { DEBUG(10,"got response of %s|%s to CANCEL",$code,$packet->msg ); invoke_callback( $param->{cb_final},'NOANSWER',$self,code => $code, packet => $packet ); } }; $noanswercb = [ $noanswercb,$self ]; weaken( $noanswercb->[1] ); # wait until final response $self->loop( $param->{ring_time}, \$stopvar ); unless ($stopvar) { # timed out $self->{endpoint}->cancel_invite( $self->{ctx},undef, $noanswercb ); $self->loop( \$stopvar ); } } else { # wait until final response $self->loop( \$stopvar ); } $param->{cb_final} = undef; } return $self->{ctx}; } ########################################################################### # cancel call # Args: ($self,%args) # %args: # cb_final: callback when CANCEL was delivered. If not given send_cancel # callback on Call object will be used # Returns: true if call could be canceled # Comment: cb_final gets triggered if the reply for the CANCEL is received # or waiting for the reply timed out ########################################################################### sub cancel { my Net::SIP::Simple::Call $self = shift; my %args = @_; my $cb = delete $args{cb_final}; %args = ( %{ $self->{param} }, %args ); $cb ||= $args{send_cancel}; my $cancel_cb = [ sub { my Net::SIP::Simple::Call $self = shift || return; my ($cb,$args,$endpoint,$ctx,$error,$code) = @_; # we don't care about the cause of this callback # it might be a successful or failed reply packet or no reply # packet at all (timeout) - the call is considered closed # in any case except for 1xx responses if ( $code && $code =~m{^1\d\d} ) { DEBUG( 10,"got prelimary response for CANCEL" ); return; } invoke_callback( $cb,$args ); }, $self,$cb,\%args ]; weaken( $cancel_cb->[1] ); return $self->{endpoint}->cancel_invite( $self->{ctx}, undef, $cancel_cb ); } ########################################################################### # end call # Args: ($self,%args) # %args: # cb_final: callback when BYE was delivered. If not given send_bye # callback on Call object will be used # Returns: NONE # Comment: cb_final gets triggered if the reply for the BYE is received # or waiting for the reply timed out ########################################################################### sub bye { my Net::SIP::Simple::Call $self = shift; my %args = @_; my $cb = delete $args{cb_final}; %args = ( %{ $self->{param} }, %args ); $cb ||= $args{send_bye}; my $bye_cb = [ sub { my Net::SIP::Simple::Call $self = shift || return; my ($cb,$args,$endpoint,$ctx,$error,$code) = @_; # we don't care about the cause of this callback # it might be a successful or failed reply packet or no reply # packet at all (timeout) - the call is considered closed # in any case except for 1xx responses # FIXME: should we check for 302 moved etc? if ( $code && $code =~m{^1\d\d} ) { DEBUG( 10,"got prelimary response for BYE" ); return; } invoke_callback( $cb,$args ); $self->cleanup; }, $self,$cb,\%args ]; weaken( $bye_cb->[1] ); $self->{endpoint}->new_request( 'BYE',$self->{ctx}, $bye_cb ); } ########################################################################### # request # Args: ($self,$method,$body,%args) # $method: method name # $body: optional body # %args: # cb_final: callback when response got received # all other args will be used to create request (mostly as header # for the request, see Net::SIP::Endpoint::new_request) # Returns: NONE ########################################################################### sub request { my Net::SIP::Simple::Call $self = shift; my ($method,$body,%args) = @_; my $cb = delete $args{cb_final}; my %cbargs = ( %{ $self->{param} }, %args ); my $rqcb = [ sub { my Net::SIP::Simple::Call $self = shift || return; my ($cb,$args,$endpoint,$ctx,$error,$code,$pkt) = @_; if ( $code && $code =~m{^1\d\d} ) { DEBUG( 10,"got prelimary response for request $method" ); return; } invoke_callback( $cb, $error ? 'FAIL':'OK', $self, { code => $code, packet => $pkt} ); }, $self,$cb,\%cbargs ]; weaken( $rqcb->[1] ); $self->{endpoint}->new_request( $method,$self->{ctx},$rqcb,$body,%args ); } ########################################################################### # send DTMF (dial tone) events # Args: ($self,$events,%args) # $events: string of characters from dial pad, any other character will # cause pause # %args: # duration: length of dial tone in milliseconds, default 100 # cb_final: callback called with (status,errormsg) when done # status can be OK|FAIL. If not given will wait until all # events are sent # methods: methods it should try for DTMF in this order # default is 'rfc2833,audio'. If none of the specified # methods is supported by peer it will croak # Returns: NONE # Comments: works only with media handling from Net::SIP::Simple::RTP ########################################################################### sub dtmf { my ($self,$events,%args) = @_; my $duration = $args{duration} || 100; my @methods = split(m{[\s,]+}, lc($args{methods}||'rfc2833,audio')); my %payload_type; while ( ! %payload_type and my $m = shift(@methods)) { my $type; if ( $m eq 'rfc2833' ) { $type = $self->{param}{sdp_peer} && $self->{param}{sdp_peer}->name2int('telephone-event/8000','audio'); } elsif ( $m eq 'audio' ) { $type = $self->{param}{sdp_peer} && $self->{param}{sdp_peer}->name2int('PCMU/8000','audio') || 0; # default id for PCMU/8000 } else { croak("unknown method $m in methods:$args{methods}"); } %payload_type = ( $m."_type" => $type ) if defined $type; } %payload_type or croak("no usable DTMF method found"); my $arr = $self->{param}{dtmf_events}; my $lastev; for( split('',$events)) { if ( m{[\dA-D*#]} ) { if (defined $lastev) { # force some silence to distinguish DTMF push @$arr, { duration => ($lastev eq $_) ? 100 : 50, %payload_type } } push @$arr, { event => $_, duration => $duration, %payload_type, }; $lastev = $_; } else { # pause push @$arr, { duration => $duration, %payload_type }; $lastev = undef; } } if ( my $cb_final = $args{cb_final} ) { push @$arr, { cb_final => $cb_final } } else { my $stopvar; push @$arr, { cb_final => \$stopvar }; $self->loop(\$stopvar); } } ########################################################################### # handle new packets within existing call # Args: ($self,$endpoint,$ctx,$error,$code,$packet,$leg,$from) # $endpoint: the endpoint # $ctx: context for call # $error: errno if error occurred # $code: code from responses # $packet: incoming packet # $leg: leg where packet came in # $from: addr from where packet came # Returns: NONE ########################################################################### sub receive { my ($self,$endpoint,$ctx,$error,$code,$packet,$leg,$from) = @_; if ( ! $packet ) { $self->error( "error occurred: $error" ); } elsif ( $packet->is_request ) { my $method = $packet->method; my $param = $self->{param}; if ( $method eq 'BYE' || $method eq 'CANCEL' ) { # tear down $self->cleanup; invoke_callback( $param->{recv_bye},$param); # everything else already handled by Net::SIP::Endpoint::Context } elsif ( $method eq 'ACK' || $method eq 'INVITE' ) { # can transport sdp data if ( my $sdp_peer = eval { $packet->sdp_body } ) { DEBUG( 50,"got sdp data from peer: ".$sdp_peer->as_string ); $self->_setup_peer_rtp_socks( $sdp_peer ); } elsif ($@) { # mailformed SDP? DEBUG(10,"SDP parsing failed, ignoring packet: $@"); return; } if ( $method eq 'INVITE' ) { if ( $param->{clear_sdp} ) { # clear SDP keys so that a new SDP session will be created @{ $param }{qw( sdp _sdp_saved sdp_peer media_ssocks media_lsocks )} = () } $param->{leg} ||= $leg; $self->_setup_local_rtp_socks; my $resp = invoke_callback($param->{cb_invite},$self,$packet); # by default send 200 OK with sdp body $resp = $packet->create_response('200','OK',{},$param->{sdp}) if ! $resp || ! UNIVERSAL::isa($resp,'Net::SIP::Packet'); DEBUG( 100,'created response '.$resp->as_string ); $self->{endpoint}->new_response( $ctx,$resp,$leg,$from ); } elsif ( $method eq 'ACK' ) { $self->rtp_cleanup; # close last RTP session invoke_callback($param->{cb_established},'OK',$self); invoke_callback($param->{init_media},$self,$param); } } elsif ( $method eq 'OPTIONS' ) { my $response = $packet->create_response( '200','OK',$self->{options} ); $self->{endpoint}->new_response( $ctx,$response,$leg,$from ); } elsif ( $method eq 'NOTIFY' ) { my $response = $packet->create_response( '200','OK' ); $self->{endpoint}->new_response( $ctx,$response,$leg,$from ); invoke_callback($param->{cb_notify},$self,$packet); } } else { # don't expect any responses. # Response to BYE is handled by Net::SIP::Endpoint::Context # other responses from the peer I don't expect DEBUG( 100,"got response. WHY? DROP." ); } } ########################################################################### # setup $self->{param} for remote socks from remote SDP data # Args: ($self,$data) # $data: packet containing sdp_body (Net::SIP::Packet) or # SDP data (Net::SIP::SDP) # Returns: NONE ########################################################################### sub _setup_peer_rtp_socks { my Net::SIP::Simple::Call $self = shift; my $param = $self->{param}; my $data = shift || $param->{sdp_peer}; my $sdp_peer; if ( UNIVERSAL::isa( $data, 'Net::SIP::Packet' )) { $sdp_peer = $data->sdp_body or do { $self->error( "No SDP body in packet" ); return; }; } else { $sdp_peer = $data } $param->{sdp_peer} = $sdp_peer; my @media = $sdp_peer->get_media; my $ls = $param->{media_lsocks}; if ( $ls && @$ls && @media != @$ls ) { $self->error( "Unexpected number of media entries in SDP from peer" ); return; } my $raddr = $param->{media_raddr} = []; my @media_dtmfxtract; for( my $i=0;$i<@media;$i++) { my $m = $media[$i]; my $range = $m->{range} || 1; my $paddr = ip_canonical($m->{addr}); if (!$m->{port} or $paddr eq '0.0.0.0' or $paddr eq '::') { # on-hold for this media push @$raddr, undef; } else { my @socks = map { ip_parts2sockaddr($m->{addr},$m->{port}+$_) } (0..$range-1); push @$raddr, @socks == 1 ? $socks[0] : \@socks; if ( $m->{media} eq 'audio' and $param->{cb_dtmf} ) { my %mt = qw(audio PCMU/8000 rfc2833 telephone-event/8000); my $mt = $param->{dtmf_methods} || 'audio,rfc2833'; my (%rmap,%pargs); for($mt =~m{([\w+\-]+)}g) { my $type = $mt{$_} or die "invalid dtmf_method: $_"; $rmap{$type} = $_.'_type'; # 0 is default type for PCMU/8000 %pargs = (audio_type => 0) if $_ eq 'audio'; } for my $l (@{$m->{lines}}) { $l->[0] eq 'a' or next; my ($type,$name) = $l->[1] =~m{^rtpmap:(\d+)\s+(\S+)} or next; my $pname = $rmap{$name} or next; $pargs{$pname} = $type; } $media_dtmfxtract[$i] = dtmf_extractor(%pargs) if %pargs; } } } $param->{media_dtmfxtract} = @media_dtmfxtract ? \@media_dtmfxtract :undef; return 1; } ########################################################################### # setup local RTP socks # Args: $self # Returns: NONE # Comments: set sdp,media_lsocks,media_ssocks in self->{param} ########################################################################### sub _setup_local_rtp_socks { my Net::SIP::Simple::Call $self = shift; my $param = $self->{param}; my $call_on_hold = $param->{call_on_hold}; $param->{call_on_hold} = 0; # one-shot my $sdp = $param->{_sdp_saved} || $param->{sdp}; if ( $sdp && !UNIVERSAL::isa( $sdp,'Net::SIP::SDP' )) { $sdp = Net::SIP::SDP->new( $sdp ); } my $laddr = $param->{leg}->laddr(0); if ( !$sdp ) { # create SDP body my $raddr = $param->{media_rsocks}; # if no raddr yet just assume one my @media; my $rp = $param->{rtp_param}; if ( my $sdp_peer = $param->{sdp_peer} ) { foreach my $m ( $sdp_peer->get_media ) { if ( $m->{proto} ne 'RTP/AVP' ) { $self->error( "only RTP/AVP supported" ); return; } my @a; if ( $m->{media} eq 'audio' ) { # enforce the payload type based on rtp_param $m = { %$m, fmt => $rp->[0] }; push @a, ( "rtpmap:$rp->[0] $rp->[3]", "ptime:".$rp->[2]*1000 ) if $rp->[3]; push @a, ( "rtpmap:101 telephone-event/8000", "fmtp:101 0-16" ); } push @media, { media => $m->{media}, proto => $m->{proto}, range => $m->{range}, fmt => [ $m->{fmt},101 ], a => \@a, }; } } else { my @a; push @a,( "rtpmap:$rp->[0] $rp->[3]" , "ptime:".$rp->[2]*1000) if $rp->[3]; my $te = $rp->[3] && $rp->[0] == 101 ? 102: 101; push @a, ( "rtpmap:$te telephone-event/8000","fmtp:$te 0-16" ); push @media, { proto => 'RTP/AVP', media => 'audio', fmt => [ $rp->[0] || 0, $te ], a => \@a, } } my $lsocks = $param->{media_lsocks} = []; foreach my $m (@media) { my ($port,@socks) = create_rtp_sockets( $laddr,$m->{range} ) or die $!; push @$lsocks, @socks == 1 ? $socks[0] : \@socks; $m->{port} = $port; } $sdp = $param->{sdp} = Net::SIP::SDP->new( { addr => $laddr }, @media ); } unless ( $param->{media_lsocks} ) { # SDP body was provided, but sockets not croak( 'not supported: if you provide SDP body you need to provide sockets too' ); } # asymetric_rtp, e.g. source socket of packet to peer is not the socket where RTP # from peer gets received if ( !$param->{media_ssocks} && $param->{asymetric_rtp} ) { my @arg = ( Proto => 'udp', LocalAddr => ( $param->{rtp_addr} || $laddr ) ); my $msocks = $param->{media_ssocks} = []; foreach my $m (@{ $param->{media_lsocks} }) { my $socks; if ( UNIVERSAL::isa( $m,'ARRAY' )) { $socks = []; foreach my $sock (@$m) { push @$socks, INETSOCK(@arg) || die $!; } } else { $socks = INETSOCK(@arg) || die $!; } push @$msocks,$socks; } } $param->{_sdp_saved} = $sdp; if ( $call_on_hold ) { $sdp = dclone($sdp); # make changes on clone my @new = map { [ '0.0.0.0',$_->{port} ] } $sdp->get_media; $sdp->replace_media_listen( @new ); $param->{sdp} = $sdp; } } 1; Net-SIP-0.822/lib/Net/SIP/Simple/RTP.pm0000644000175100017510000003326213370543213015626 0ustar workwork########################################################################### # Net::SIP::Simple::RTP # implements some RTP behaviors # - media_recv_echo: receive and echo data with optional delay back # can save received data # - media_send_recv: receive and optionally save data. Sends back data # from file with optional repeat count ########################################################################### use strict; use warnings; package Net::SIP::Simple::RTP; use Net::SIP::Util qw(invoke_callback ip_sockaddr2parts ip_parts2string); use Socket; use Net::SIP::Debug; use Net::SIP::DTMF; use Net::SIP::Dispatcher::Eventloop; # on MSWin32 non-blocking sockets are not supported from IO::Socket use constant CAN_NONBLOCKING => $^O ne 'MSWin32'; ########################################################################### # creates function which will initialize Media for echo back # Args: ($writeto,$delay) # $delay: how much packets delay between receive and echo back (default 0) # if <0 no ddata will be send back (e.g. recv only) # $writeto: where to save received data (default: don't save) # Returns: [ \&sub,@args ] ########################################################################### sub media_recv_echo { my ($writeto,$delay) = @_; my $sub = sub { my ($delay,$writeto,$call,$args) = @_; my $lsocks = $args->{media_lsocks}; my $ssocks = $args->{media_ssocks} || $lsocks; my $raddr = $args->{media_raddr}; my $mdtmf = $args->{media_dtmfxtract}; my $didit = 0; for( my $i=0;$i<@$lsocks;$i++ ) { my $sock = $lsocks->[$i] || next; $sock = $sock->[0] if UNIVERSAL::isa( $sock,'ARRAY' ); my $s_sock = $ssocks->[$i]; $s_sock = $s_sock->[0] if UNIVERSAL::isa( $s_sock,'ARRAY' ); my $addr = $raddr->[$i]; $addr = $addr->[0] if ref($addr); my @delay_buffer; my $channel = $i; my $echo_back = sub { my ($s_sock,$remote,$delay_buffer,$delay,$writeto,$targs,$didit,$sock) = @_; { my ($buf,$mpt,$seq,$tstamp,$ssrc,$csrc) = _receive_rtp($sock,$writeto,$targs,$didit,$channel) or last; #DEBUG( "$didit=$$didit" ); $$didit = 1; last if ! $s_sock || ! $remote; # call on hold ? my @pkt = _generate_dtmf($targs,$seq,$tstamp,0x1234); if (@pkt && $pkt[0] ne '') { DEBUG( 100,"send DTMF to RTP"); send( $s_sock,$_,0,$remote ) for(@pkt); return; # send DTMF *instead* of echo data } last if $delay<0; push @$delay_buffer, $buf; while ( @$delay_buffer > $delay ) { send( $s_sock,shift(@$delay_buffer),0,$remote ); } CAN_NONBLOCKING && redo; # try recv again } }; $call->{loop}->addFD($sock, EV_READ, [ $echo_back,$s_sock,$addr,\@delay_buffer,$delay || 0,$writeto,{ dtmf_gen => $args->{dtmf_events}, dtmf_xtract => $mdtmf && $mdtmf->[$i] && $args->{cb_dtmf} && [ $mdtmf->[$i], $args->{cb_dtmf} ], },\$didit ], 'rtp_echo_back' ); my $reset_to_blocking = CAN_NONBLOCKING && $s_sock->blocking(0); push @{ $call->{ rtp_cleanup }}, [ sub { my ($call,$sock,$rb) = @_; DEBUG( 100,"rtp_cleanup: remove socket %d",fileno($sock)); $call->{loop}->delFD( $sock ); $sock->blocking(1) if $rb; }, $call,$sock,$reset_to_blocking ]; } # on RTP inactivity for at least 10 seconds close connection my $timer = $call->{dispatcher}->add_timer( 10, [ sub { my ($call,$didit,$timer) = @_; if ( $$didit ) { $$didit = 0; } else { DEBUG(10, "closing call because if inactivity" ); $call->bye; $timer->cancel; } }, $call,\$didit ], 10, 'rtp_inactivity', ); push @{ $call->{ rtp_cleanup }}, [ sub { shift->cancel; DEBUG( 100,"cancel RTP timer" ); }, $timer ]; }; return [ $sub,$delay,$writeto ]; } ########################################################################### # creates function which will initialize Media for saving received data # into file and sending data from another file # Args: ($readfrom;$repeat,$writeto) # $readfrom: where to read data for sending from (filename or callback # which returns payload) # $repeat: if <= 0 the data in $readfrom will be send again and again # if >0 the data in $readfrom will be send $repeat times # $writeto: where to save received data (undef == don't save), either # filename or callback which gets packet as argument # Returns: [ \&sub,@args ] ########################################################################### sub media_send_recv { my ($readfrom,$repeat,$writeto) = @_; my $sub = sub { my ($writeto,$readfrom,$repeat,$call,$args) = @_; my $lsocks = $args->{media_lsocks}; my $ssocks = $args->{media_ssocks} || $lsocks; my $raddr = $args->{media_raddr}; my $mdtmf = $args->{media_dtmfxtract}; my $didit = 0; for( my $i=0;$i<@$lsocks;$i++ ) { my $channel = $i; my $sock = $lsocks->[$i]; my ($timer,$reset_to_blocking); # recv once I get an event on RTP socket if ($sock) { $sock = $sock->[0] if UNIVERSAL::isa( $sock,'ARRAY' ); my $receive = sub { my ($writeto,$targs,$didit,$sock) = @_; while (1) { my $buf = _receive_rtp($sock,$writeto,$targs,$didit,$channel); defined($buf) or return; CAN_NONBLOCKING or return; } }; $call->{loop}->addFD($sock, EV_READ, [ $receive, $writeto, { dtmf_gen => $args->{dtmf_events}, dtmf_xtract => $mdtmf && $mdtmf->[$i] && $args->{cb_dtmf} && [ $mdtmf->[$i], $args->{cb_dtmf} ], }, \$didit ], 'rtp_receive' ); $reset_to_blocking = CAN_NONBLOCKING && $sock->blocking(0); } # sending need to be done with a timer # ! $addr == call on hold my $addr = $raddr->[$i]; $addr = $addr->[0] if ref($addr); if ($addr and my $s_sock = $ssocks->[$i]) { $s_sock = $s_sock->[0] if UNIVERSAL::isa( $s_sock,'ARRAY' ); my $cb_done = $args->{cb_rtp_done} || sub { shift->bye }; $timer = $call->{dispatcher}->add_timer( 0, # start immediately [ \&_send_rtp,$s_sock,$call->{loop},$addr,$readfrom,$channel, { repeat => $repeat || 1, cb_done => [ sub { invoke_callback(@_) }, $cb_done, $call ], rtp_param => $args->{rtp_param}, dtmf_gen => $args->{dtmf_events}, dtmf_xtract => $mdtmf && $mdtmf->[$i] && $args->{cb_dtmf} && [ $mdtmf->[$i], $args->{cb_dtmf} ], }], $args->{rtp_param}[2], # repeat timer 'rtpsend', ); } push @{ $call->{rtp_cleanup}}, [ sub { my ($call,$sock,$timer,$rb) = @_; if ($sock) { $call->{loop}->delFD($sock); $sock->blocking(1) if $rb; } $timer->cancel() if $timer; }, $call,$sock,$timer,$reset_to_blocking ]; } # on RTP inactivity for at least 10 seconds close connection my $timer = $call->{dispatcher}->add_timer( 10, [ sub { my ($call,$args,$didit,$timer) = @_; if ( $$didit ) { $$didit = 0; } else { DEBUG( 10,"closing call because if inactivity" ); $call->bye; $timer->cancel; } }, $call,$args,\$didit ], 10, 'rtp_inactivity', ); push @{ $call->{ rtp_cleanup }}, [ sub { shift->cancel }, $timer ]; }; return [ $sub,$writeto,$readfrom,$repeat ]; } ########################################################################### # Helper to receive RTP and optionally save it to file # Args: ($sock,$writeto,$targs,$didit,$channel) # $sock: RTP socket # $writeto: filename for saving or callback which gets packet as argument # $targs: \%hash to hold state info between calls of this function # $didit: reference to scalar which gets set to TRUE on each received packet # and which gets set to FALSE from a timer, thus detecting inactivity # $channel: index of RTP channel # Return: $packet # $packet: received RTP packet (including header) ########################################################################### sub _receive_rtp { my ($sock,$writeto,$targs,$didit,$channel) = @_; my $from = recv( $sock,my $buf,2**16,0 ); return if ! $from || !defined($buf) || $buf eq ''; DEBUG( 50,"received %d bytes from RTP", length($buf)); if(0) { DEBUG( "got data on socket %d %s from %s",fileno($sock), ip_sockaddr2string(getsockname($sock)), ip_sockaddr2string($from)); } $$didit = 1; my $packet = $buf; my ($vpxcc,$mpt,$seq,$tstamp,$ssrc) = unpack( 'CCnNN',substr( $buf,0,12,'' )); my $version = ($vpxcc & 0xc0) >> 6; if ( $version != 2 ) { DEBUG( 100,"RTP version $version" ); return } # skip csrc headers my $cc = $vpxcc & 0x0f; my $csrc = $cc && substr( $buf,0,4*$cc,'' ); # skip extension header my $xh = $vpxcc & 0x10 ? (unpack( 'nn', substr( $buf,0,4,'' )))[1] : 0; substr( $buf,0,4*$xh,'' ) if $xh; # ignore padding my $padding = $vpxcc & 0x20 ? unpack( 'C', substr($buf,-1,1)) : 0; my $payload = $padding ? substr( $buf,0,length($buf)-$padding ): $buf; DEBUG( 100,"ch=%d payload=%d/%d pt=%d xh=%d padding=%d cc=%d", $channel, $seq, length($payload), $mpt & 0x7f, $xh, $padding, $cc); if ( $targs->{rseq} && $seq<= $targs->{rseq} && $targs->{rseq} - $seq < 60000 ) { DEBUG( 10,"seq=$seq last=$targs->{rseq} - dropped" ); return; } $targs->{rseq} = $seq; if ( ref($writeto)) { # callback invoke_callback($writeto,$payload,$seq,$tstamp,$channel,$mpt & 0x7f); } elsif ( $writeto ) { # save into file my $fd = $targs->{fdr}; if ( !$fd ) { open( $fd,'>',$writeto ) || die $!; $targs->{fdr} = $fd } syswrite($fd,$payload); } if ( my $xt = $targs->{dtmf_xtract} ) { my ($sub,$cb) = @$xt; if ( my ($event,$duration) = $sub->($packet)) { DEBUG(40,"received dtmf <$event,$duration>"); $cb->($event,$duration); } } return wantarray ? ( $packet,$mpt,$seq,$tstamp,$ssrc,$csrc ): $packet; } ########################################################################### # Helper to read RTP data from file (PCMU 8000) and send them through # the RTP socket # Args: ($sock,$loop,$addr,$readfrom,$targs,$timer) # $sock: RTP socket # $loop: event loop (used for looptime for timestamp) # $addr: where to send data # $readfrom: filename for reading or callback which will return payload # $channel: index of RTP channel # $targs: \%hash to hold state info between calls of this function # especially 'repeat' holds the number of times this data has to be # send (<=0 means forever) and 'cb_done' holds a [\&sub,@arg] callback # to end the call after sending all data # 'repeat' makes only sense if $readfrom is filename # $timer: timer which gets canceled once all data are send # Return: NONE ########################################################################### sub _send_rtp { my ($sock,$loop,$addr,$readfrom,$channel,$targs,$timer) = @_; $targs->{wseq}++; my $seq = $targs->{wseq}; # 32 bit timestamp based on seq and packet size my $timestamp = ( $targs->{rtp_param}[1] * $seq ) % 2**32; my @pkt = _generate_dtmf($targs,$seq,$timestamp,0x1234); if (@pkt && $pkt[0] ne '') { DEBUG( 100,"send DTMF to RTP"); send( $sock,$_,0,$addr ) for(@pkt); return; } my $buf; my $rtp_event; my $payload_type; if ( ref($readfrom) ) { # payload by callback $buf = invoke_callback($readfrom,$seq,$channel); if ( !$buf ) { DEBUG( 50, "no more data from callback" ); $timer && $timer->cancel; invoke_callback( $targs->{cb_done} ); return; } ($buf,$payload_type,$rtp_event,$timestamp) = @$buf if ref($buf); } else { # read from file for(my $tries = 0; $tries<2;$tries++ ) { $targs->{wseq} ||= int( rand( 2**16 )); my $fd = $targs->{fd}; if ( !$fd ) { $targs->{repeat} = -1 if $targs->{repeat} < 0; if ( $targs->{repeat} == 0 ) { # no more sending DEBUG( 50, "no more data from file" ); $timer && $timer->cancel; invoke_callback( $targs->{cb_done} ); return; } open( $fd,'<',$readfrom ) || die $!; $targs->{fd} = $fd; } my $size = $targs->{rtp_param}[1]; # 160 for PCMU/8000 last if read( $fd,$buf,$size ) == $size; # try to reopen file close($fd); $targs->{fd} = undef; $targs->{repeat}--; } } die $! if ! defined $buf or $buf eq ''; if (0) { DEBUG(50, "%s -> %s seq=%d ts=%x", ip_sockaddr2string(getsockname($sock)), ip_sockaddr2string($addr), $seq, $timestamp ); } # add RTP header $rtp_event = 0 if ! defined $rtp_event; $payload_type = $targs->{rtp_param}[0]||0 # 0 == PMCU 8000 if ! defined $payload_type; my $header = pack('CCnNN', 0b10000000, # Version 2 $payload_type | ( $rtp_event << 7 ) , $seq, # sequence $timestamp, 0x1234, # source ID ); DEBUG( 100,"send %d bytes to RTP", length($buf)); send( $sock,$header.$buf,0,$addr ); } ########################################################################### # Helper to send DTMF # Args: ($targs,$seq,$timestamp,$srcid) # $targs: hash which is shared with _send_rtp and other callbacks, contains # dtmf array with events # $seq,$timestamp,$srcid: parameter for RTP packet # Returns: @pkt # (): no DTMF events to handle # $pkt[0] eq '': DTMF in process, but no data # @pkt: RTP packets to send ########################################################################### sub _generate_dtmf { my ($targs,$seq,$timestamp,$srcid) = @_; my $dtmfs = $targs->{dtmf_gen}; $dtmfs and @$dtmfs or return; while ( @$dtmfs ) { my $dtmf = $dtmfs->[0]; if ( my $duration = $dtmf->{duration} ) { DEBUG(40,"generate dtmf ".( $dtmf->{sub} ? '' : defined $dtmf->{event} ? "<$dtmf->{event},$duration>" : "" )); my $cb = $dtmf->{sub} ||= dtmf_generator($dtmf->{event},$duration,%$dtmf); my @pkt = $cb->($seq,$timestamp,$srcid); return @pkt if @pkt; } shift(@$dtmfs); if ( my $cb = $dtmf->{cb_final} ) { invoke_callback($cb,'OK'); } } return; } 1; Net-SIP-0.822/lib/Net/SIP/Blocker.pod0000644000175100017510000000166411423326607015463 0ustar workwork =head1 NAME Net::SIP::Blocker - blocks SIP requests based on method name =head1 SYNOPSIS my $block = Net::SIP::Blocker->new( block => { 'SUBSCRIBE' => 405, '...' => ... }, dispatcher => $disp, ); my $chain = Net::SIP::ReceiveChain->new( [ $block, ... ] ); =head1 DESCRIPTION Blocks incoming requests by method name and sends back custom error message. =head1 CONSTRUCTOR =over 4 =item new ( BLOCK,DISPATCHER ) Returns a new blocking object to be used in the chain. BLOCK is a hash reference where the keys are the methods to be blocked and their values are the reason why the method was blocked. The reason is the three digit code, optionally followed by a text. DISPATCHER is a L object. =back =head1 METHODS =over 4 =item receive ( PACKET,LEG,FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. =back Net-SIP-0.822/lib/Net/SIP/Endpoint.pm0000644000175100017510000003146513551637244015524 0ustar workwork ############################################################################ # package Net::SIP::Endpoint # implements the behavior of an endpoint (SIP phone). # packet managment (lower layer) is done by Net::SIP::Dispatcher while # call managment is done with Net::SIP::Endpoint::Context ############################################################################ use strict; use warnings; package Net::SIP::Endpoint; use fields ( 'dispatcher', # lower layer, delivers and receives packets through the legs 'application', # upper layer, e.g user interface.. 'ctx' # hash of ( callid => Net::SIP::Endpoint::Context ) ); use Net::SIP::Debug; use Net::SIP::Endpoint::Context; use Net::SIP::Util qw(invoke_callback); use Scalar::Util 'weaken'; ############################################################################ # create a new endpoint # Args: ($class,$dispatcher) # $dispatcher: lower layer which handles the delivery and receiving of packets # Returns: $self ############################################################################ sub new { my ($class,$dispatcher) = @_; my $self = fields::new($class); $self->{dispatcher} = $dispatcher; $self->{ctx} = {}; # \%hash with ( callid => $ctx ) # announce myself as upper layer for incoming packets to # the dispatcher my $cb = [ \&receive,$self ]; weaken( $cb->[1] ); $dispatcher->set_receiver( $cb ); return $self; } ############################################################################ # set upper layer (application) # Args: ($self,$app) # $app: upper layer which needs to have method receive( $request ) # to handle new request, which this layer cannot handle alone # (e.g INVITE to a new dialog) # or this can be \&sub, [ \&sub,@arg ]... # Returns: NONE ############################################################################ sub set_application { my Net::SIP::Endpoint $self = shift; my $app = shift; my $cb; if ( my $sub = UNIVERSAL::can( $app,'receive' )) { $cb = [ $sub,$app ]; } else { $cb = $app; # already callback } $self->{application} = $cb; } ############################################################################ # create a new call or re-invite on a existing call # wrapper around new_request() # Args: ($self,$ctx;$callback,$body,%args) # $ctx: Context|\%args, see new_request() # $callback: optional Callback, see new_request() # $body: optional Body # %args: additional args for Net::SIP::Request::new # Returns: $ctx # $ctx: see new_request() ############################################################################ sub invite { my Net::SIP::Endpoint $self = shift; my ($ctx,$callback,$body,%args) = @_; return $self->new_request( 'INVITE',$ctx,$callback,$body,%args ); } ############################################################################ # registers UAC # Args: ($self,%args) # %args: at minimum there must be # from: the sip-address to register # contact: to which local address should it registered # registrar: SIP address of registrar # there can be: # expires: Expires header, defaults to 900 if not given # callback: callback which will be called on response # callid: callid used for calling context # all other args will be used in creation of request # Returns: NONE ############################################################################ sub register { my Net::SIP::Endpoint $self = shift; my %args = @_; my ($me,$registrar,$contact) = delete @args{qw( from registrar contact )}; my $expires = delete $args{expires}; $expires = 900 if !defined($expires); my %ctx = ( to => $me, from => $me, contact => $contact, auth => delete $args{auth}, callid => delete $args{callid}, ); return $self->new_request( 'REGISTER', \%ctx, delete($args{callback}), undef, uri => $registrar, expires => $expires, %args, ); } ############################################################################ # starts new request, e.g creates request packet and delivers it # Args: ($self,$method,$ctx;$callback,$body,%args) # $method: method name, e.g. 'INVITE','REGISTER',.. # can also be a full Net::SIP::Request already (used for retries after # 302,305 responses) # $ctx: already established context (Net::SIP::Endpoint::Context) # or \%hash to create a new one (see Net::SIP::Endpoint::Context->new) # $callback: [ \&sub,@arg ] which will be called if the layer receives # responses important to the upper layer (e.g 180 Ringing, 200 Ok, # 401/407 Authorization required...) # if callback is omitted the callback from the context is used, # if callback is set it will be the new callback for the context # $body: optional Body, either scalar or smth with method as_string # (like Net::SIP::SDP) # %args: additional args for Net::SIP::Endpoint::Context::new_request # Returns: $ctx # $ctx: context, eg the original one or newly created # Comment: if it cannot create a new context (because of missing args) # or something else fatal happens it will die() ############################################################################ sub new_request { my Net::SIP::Endpoint $self = shift; my ($method,$ctx,$callback,$body,%args) = @_; die "cannot redefine call-id" if delete $args{ 'call-id' }; if ( ! UNIVERSAL::isa( $ctx,'Net::SIP::Endpoint::Context' )) { $ctx = Net::SIP::Endpoint::Context->new(%$ctx, method => $method); $self->{ctx}{ $ctx->callid } = $ctx; # make sure we manage the context DEBUG( 10,"create new request for $method within new call ".$ctx->callid ); } else { DEBUG( 10,"create new request for $method within existing call ".$ctx->callid ); } $ctx->set_callback( $callback ) if $callback; my $request = $ctx->new_request( $method,$body,%args ); DEBUG( 50,"request=".$request->as_string ); my $tid = $request->tid; $self->{dispatcher}->deliver( $request, id => $tid, callback => [ \&_request_delivery_callback, $self,$ctx ], leg => $args{leg}, dst_addr => $args{dst_addr}, ); return $ctx; } ############################################################################ # Cancel last pending INVITE request # Args: ($self,$ctx,$request,$cb) # $ctx: context for call # $request: request to cancel, will only cancel it, if request is # outstanding in context, will cancel latest INVITE if not given # $cb: callback for generated CANCEL request # Returns: number of requests canceled (e.g 0 if no outstanding INVITE) ############################################################################ sub cancel_invite { my Net::SIP::Endpoint $self = shift; my Net::SIP::Endpoint::Context $ctx = shift; my ($request,$callback) = @_; my ($pkt) = $ctx->find_outstanding_requests( $request ? ( request => $request ) : ( method => 'INVITE' ) ) or return; $self->new_request( $pkt->create_cancel, $ctx, $callback ); return 1; } ############################################################################ # internal callback used for delivery # will be called from dispatcher if the request was definitely successfully # delivered (tcp only) or an error occurred # Args: ($self,$ctx,$error,$delivery_packet) # $ctx: Net::SIP::Endpoint::Context # $error: errno if error occurred # $delivery_packet: Net::SIP::Dispatcher::Packet which encapsulates # the original request and information about leg, dst_addr... # and has method use_next_dstaddr to try the next dstaddr if for the # current no (more) retries are possible # Returns: NONE ############################################################################ sub _request_delivery_callback { my Net::SIP::Endpoint $self = shift; my ($ctx,$error,$delivery_packet) = @_; my $tid = $delivery_packet->tid; # either successfully send over reliable transport # or permanently failed, e.g no (more) retries possible $ctx->request_delivery_done( $self,$tid,$error ) } ############################################################################ # remove context from Endpoint and cancel all outstanding deliveries # Args: ($self,$id) # $id: either id for ctx or context object or SIP packet # Returns: $ctx # $ctx: removed context object ############################################################################ sub close_context { my Net::SIP::Endpoint $self = shift; my $id = shift; $id = $id->callid if ref($id); DEBUG( 10,"close context call-id $id " ); my $ctx = delete $self->{ctx}{$id} || do { DEBUG( 50,"no context for call-id $id found" ); return; }; # cancel all outstanding deliveries $self->{dispatcher}->cancel_delivery( callid => $id ); return $ctx; } ############################################################################ # receive packet from dispatcher and forwards it to receive_response # or receive_request depending on type of packet # Args: ($self,$packet,$leg,$from) # $packet: Net::SIP::Packet # $leg: Net::SIP::Leg through which the packets was received # $from: hash with information where it got packet from # Returns: NONE ############################################################################ sub receive { my Net::SIP::Endpoint $self = shift || return; my ($packet,$leg,$from) = @_; return $packet->is_response ? $self->receive_response( $packet,$leg,$from ) : $self->receive_request( $packet,$leg,$from ) ; } ############################################################################ # Handle incoming response packet # Args: ($self,$response,$leg,$from) # $response: incoming Net::SIP::Response packet # $leg: where response came in # $from: hash with information where it got response from # Returns: NONE ############################################################################ sub receive_response { my Net::SIP::Endpoint $self = shift; my ($response,$leg,$from) = @_; # find context for response or drop my $callid = $response->get_header( 'call-id' ); my $ctx = $self->{ctx}{$callid} || do { DEBUG( 50,"cannot find context for packet with callid=$callid. DROP"); return; }; DEBUG( 10,"received reply for tid=".$response->tid ); $self->{dispatcher}->cancel_delivery( $response->tid ); $ctx->handle_response( $response,$leg,$from,$self ); } ############################################################################ # Handle incoming request packet # Args: ($self,$request,$leg,$from) # $request: incoming Net::SIP::Request packet # $leg: where response came in # $from: hash with information where it got response from # Returns: NONE ############################################################################ sub receive_request { my Net::SIP::Endpoint $self = shift; my ($request,$leg,$from) = @_; # this might be a request for an existing context or for a new context my $callid = $request->get_header( 'call-id' ); my $ctx = $self->{ctx}{$callid}; my $method = $request->method; if ( ! $ctx ) { if ( $method eq 'BYE' || $method eq 'CANCEL' ) { # no context for this call, reply with 481 call does not exist # (RFC3261 15.1.2) $self->new_response( undef, $request->create_response( 481,'call does not exist' ), $leg, # send back thru same leg $from, # and back to the sender ); return; } elsif ( $method eq 'ACK' ) { # call not exists (maybe closed because of CANCEL) DEBUG(99,'ignoring ACK for non-existing call'); return; } # create a new context; $ctx = Net::SIP::Endpoint::Context->new( incoming => 1, method => $method, from => scalar( $request->get_header( 'from' )), to => scalar( $request->get_header( 'to' )), remote_contact => scalar( $request->get_header( 'contact' )), callid => scalar( $request->get_header( 'call-id' )), via => [ $request->get_header( 'via' ) ], ); $ctx->set_callback( sub { my ($self,$ctx,undef,undef,$request,$leg,$from) = @_; invoke_callback( $self->{application}, $self,$ctx,$request,$leg,$from ); }); } # if I got an ACK cancel delivery of Response to INVITE if ( $method eq 'ACK' ) { $self->{dispatcher}->cancel_delivery( $request->tid ); } $ctx->handle_request( $request,$leg,$from,$self ); } ############################################################################ # deliver a response packet # Args: ($self,$ctx,$response,$leg,$addr) # $ctx : Net::SIP::Endpoint::Context which generated response # $response: Net::SIP::Response packet # $leg : leg to send out response, eg where the request came in # $addr : where to send respone (ip:port), eg where the request came from # Returns: NONE ############################################################################ sub new_response { my Net::SIP::Endpoint $self = shift; my ($ctx,$response,$leg,$addr) = @_; $self->{ctx}{ $ctx->callid } = $ctx if $ctx; # keep context $self->{dispatcher}->deliver( $response, leg => $leg, dst_addr => $addr, ); } 1; Net-SIP-0.822/lib/Net/SIP/Dropper.pm0000644000175100017510000000543212271422677015352 0ustar workwork =head1 NAME Net::SIP::Dropper - drops SIP messages based on callback =head1 SYNOPSIS use Net::SIP::Dropper::ByIPPort; my $drop_by_ipport = Net::SIP::Dropper::ByIPPort->new( database => '/path/to/database.drop', methods => [ 'REGISTER', '...', '' ], attempts => 10, interval => 60, ); use Net::SIP::Dropper::ByField; my $drop_by_field = Net::SIP::Dropper::ByField->new( methods => [ 'REGISTER', '...', '' ], 'From' => qr/sip(?:vicious|sscuser)/, 'User-Agent' => qr/^friendly-scanner$/, ); my $drop_subscribe = sub { my ($packet,$leg,$from) = @_; # drop all subscribe requests and responses return $packet->method eq 'SUBSCRIBE' ? 1:0; }; my $dropper = Net::SIP::Dropper->new( cbs => [ $drop_by_ipport, $drop_by_field, $drop_subscribe ]); my $chain = Net::SIP::ReceiveChain->new( [ $dropper, ... ] ); =head1 DESCRIPTION Drops messages. This means, does no further processing in the Net::SIP chain and does not send something back if the incoming message match the settings. Some useful droppers are defined in L and L. =head1 CONSTRUCTOR =over 4 =item new ( ARGS ) ARGS is a hash with key C I C. C is a single callback to be processed, C is an arrayref with callbacks. If one of the callbacks returns true the message will be dropped. If all callbacks return false the message will be forwarded in the chain. Returns a new dropper object to be used in the chain. =back =cut use strict; use warnings; package Net::SIP::Dropper; use fields qw( cbs ); use Carp 'croak'; use Net::SIP::Util qw( invoke_callback ); ################################################################################ # creates new Dropper object # Args: ($class,%args) # %args: # One of cb or cbs must be set. # cb: A single callback. Will be ignored if cbs is also set. # cbs: An arrayref with callbacks. # Returns: Net::SIP::Dropper object ################################################################################ sub new { my ($class, %args) = @_; my Net::SIP::Dropper $self = fields::new($class); croak('argument cb or cbs must exist') unless $args{cb} || $args{cbs}; $self->{cbs} = $args{cbs} || [ $args{cb} ]; return $self; } ################################################################################ # Drops SIP-messages excluded by the settings # Args: ($self,$packet,$leg,$from) # args as usual for sub receive # Returns: 1 (stop chain) | (proceed in chain) ################################################################################ sub receive { my Net::SIP::Dropper $self = shift; my ($packet, $leg, $from) = @_; for (@{ $self->{cbs} }) { return 1 if invoke_callback($_, $packet, $leg, $from); } return; } 1; Net-SIP-0.822/lib/Net/SIP/Simple.pm0000644000175100017510000004721613243473376015200 0ustar workwork######################################################################### # Net::SIP::Simple # simple methods for creation of UAC,UAS # - register register Address # - invite create new call # - listen UAS, wait for incoming requests # - create_registrar - create a simple registrar # - create_stateless_proxy - create a simple stateless proxy ########################################################################### use strict; use warnings; package Net::SIP::Simple; use fields ( 'endpoint', # Net::SIP::Endpoint 'dispatcher', # Net::SIP::Dispatcher 'loop', # Net::SIP::Dispatcher::Eventloop or similar 'outgoing_proxy', # optional outgoing proxy (SIP URL) 'route', # more routes 'registrar', # optional registrar (addr:port) 'auth', # Auth data, see Net::SIP::Endpoint 'from', # SIP address of caller 'contact', # optional local contact address 'domain', # default domain for SIP addresses 'last_error', # last error 'options', # hash with field,values for response to OPTIONS request 'ua_cleanup', # cleanup callbacks ); use Carp qw(croak); use Net::SIP::Dispatcher; use Net::SIP::Dispatcher::Eventloop; use Net::SIP::Endpoint; use Net::SIP::Redirect; use Net::SIP::Registrar; use Net::SIP::StatelessProxy; use Net::SIP::Authorize; use Net::SIP::ReceiveChain; use Net::SIP::Leg; # crossref, because its derived from Net::SIP::Simple # now load in Net::SIP # use Net::SIP::Simple::Call; use Net::SIP::Simple::RTP; use Net::SIP::Util qw( :all ); use List::Util 'first'; use Net::SIP::Debug; ########################################################################### # create UA # Args: ($class;%args) # %args: misc args, all args are optional # legs|leg - \@list of legs or single leg. # leg can be (derived from) Net::SIP::Leg, a IO::Handle (socket), # a hash reference for constructing Net::SIP::Leg or a string # with a SIP address (i.e. sip:ip:port;transport=TCP) # tls - common TLS settings used when creating a leg # outgoing_proxy - specify outgoing proxy, will create leg if necessary # proxy - alias to outgoing_proxy # route|routes - \@list with SIP routes in right syntax ""... # registrar - use registrar for registration # auth - auth data: see Request->authorize for format # from - myself, used for calls and registration # contact - optional local contact address # options - hash with fields,values for reply to OPTIONS request # loop - predefined Net::SIP::Dispatcher::Eventloop, used if # shared between UAs # dispatcher - predefined Net::SIP::Dispatcher, used if # shared between UAs # domain - domain used if from/to.. do not contain domain # domain2proxy - hash of { domain => proxy } # used to find proxy for domain. If nothing matches here # DNS need to be used. Special domain '*' catches all # d2p - alias for domain2proxy # Returns: $self # Comment: # FIXME # If more than one leg is given (e.g. legs+outgoing_proxy) than you have # to provide a function to find out, which leg is used to send out a request ########################################################################### sub new { my ($class,%args) = @_; my $auth = delete $args{auth}; my $registrar = delete $args{registrar}; my $tls = delete $args{tls}; my $ua_cleanup = []; my $self = fields::new( $class ); my $options = delete $args{options} || {}; { @{$options}{ map { lc } keys(%$options) } = values(%$options); # lc keys my %default_options = ( allow => 'INVITE, ACK, CANCEL, OPTIONS, BYE', accept => 'application/sdp', 'accept-encoding' => '', 'accept-language' => 'en', supported => '', ); while ( my ($k,$v) = each %default_options ) { $options->{$k} = $v if ! defined $options->{$k}; } } my $disp = delete $args{dispatcher}; my $loop = $disp && $disp->loop || delete $args{loop} || Net::SIP::Dispatcher::Eventloop->new; my $proxy = delete $args{outgoing_proxy} || delete $args{proxy}; my $d2p = delete $args{domain2proxy} || delete $args{d2p}; $disp ||= Net::SIP::Dispatcher->new( [], $loop, domain2proxy => $d2p, ); my $legs = delete $args{legs} || delete $args{leg}; $legs = [ $legs ] if $legs && ref($legs) ne 'ARRAY'; $legs ||= []; my $host2ip = sub { my $host = shift; my $ip; $disp->dns_host2ip($host,sub { $ip = shift // \0 }); $loop->loop(15,\$ip); die "failed to resolve $host".($ip ? '':' - timed out') if ! defined $ip || ref($ip); return ($ip,ip_is_v46($ip)); }; foreach ($legs ? @$legs : ()) { if ( UNIVERSAL::isa( $_, 'Net::SIP::Leg' )) { # keep } elsif ( UNIVERSAL::isa( $_, 'IO::Handle' )) { # socket $_ = Net::SIP::Leg->new( sock => $_, tls => $tls ) } elsif ( UNIVERSAL::isa( $_, 'HASH' )) { # create leg from hash $_ = Net::SIP::Leg->new(tls => $tls, %$_) } elsif (my ($proto,$host,$port,$family) = sip_uri2sockinfo($_)) { (my $addr,$family) = $family ? ($host,$family) : $host2ip->($host); $_ = Net::SIP::Leg->new( proto => $proto, tls => $tls, host => $host, addr => $addr, port => $port, family => $family ); } else { die "invalid leg specification: $_"; } } for my $dst ($registrar, $proxy) { $dst or next; first { $_->can_deliver_to($dst) } @$legs and next; my ($proto,$host,$port,$family) = sip_uri2sockinfo($dst); (my $addr,$family) = $family ? ($host,$family) : $host2ip->($host); push @$legs, Net::SIP::Leg->new( proto => $proto, tls => $tls, dst => { host => $host, addr => $addr, port => $port, family => $family, } ); } $disp->add_leg(@$legs) if @$legs; $disp->outgoing_proxy($proxy) if $proxy; push @$ua_cleanup, [ sub { my ($self,$legs) = @_; $self->{dispatcher}->remove_leg(@$legs); }, $self,$legs ] if @$legs; my $endpoint = Net::SIP::Endpoint->new( $disp ); my $routes = delete $args{routes} || delete $args{route}; my $from = delete $args{from}; my $contact = delete $args{contact}; my $domain = delete $args{domain}; if ($from) { if (!defined($domain) && $from =~m{\bsips?:[^@]+\@([\w\-\.]+)}) { $domain = $1; } if ($from !~m{\s} && $from !~m{\@}) { my $sip_proto = $disp->get_legs(proto => 'tls') ? 'sips' : 'sip'; $from = "$from <$sip_proto:$from\@$domain>"; } } die "unhandled arguments: ".join(", ", keys %args) if %args; %$self = ( auth => $auth, from => $from, contact => $contact, domain => $domain, endpoint => $endpoint, registrar => $registrar, dispatcher => $disp, loop => $loop, route => $routes, options => $options, ua_cleanup => $ua_cleanup, ); return $self; } ########################################################################### # cleanup object, e.g. remove legs it added to dispatcher # Args: ($self) # Returns: NONE ########################################################################### sub cleanup { my Net::SIP::Simple $self = shift; while ( my $cb = shift @{ $self->{ua_cleanup} } ) { invoke_callback($cb,$self) } %$self = (); } ########################################################################### # get last error or set it # Args: ($self;$err) # $err: if given will set error # Returns: $last_error ########################################################################### sub error { my Net::SIP::Simple $self = shift; if ( @_ ) { $self->{last_error} = shift; $DEBUG && DEBUG(100,Net::SIP::Debug::stacktrace( "set error to ".$self->{last_error}) ); } return $self->{last_error}; } ########################################################################### # mainloop # Args: (;$timeout,@stopvar) # $timeout: timeout, undef for no timeout. argument can be omitted # @stopvar: @array of Scalar-REF, loop stops if one scalar is true # Returns: NONE ########################################################################### sub loop { my Net::SIP::Simple $self = shift; my ($timeout,@stopvar); foreach (@_) { if ( ref($_) ) { push @stopvar,$_ } elsif ( defined($_)) { $timeout = $_ } } return $self->{loop}->loop( $timeout,@stopvar ); } ########################################################################### # add timer # propagates to add_timer of wNet::SIP::Dispatcher, see there for detailed # explanation of args # Args: ($self,$when,$cb,$repeat) # Returns: $timer ########################################################################### sub add_timer { my Net::SIP::Simple $self = shift; $self->{dispatcher}->add_timer( @_ ); } ########################################################################### # control RTP behavior # Args: ($self,$method,@arg) # $method: Method name for behavior, e.g. calls Net::SIP::Simple::RTP::$method # @arg: Arguments for method # Returns: $cb # $cb: callback structure ########################################################################### sub rtp { my Net::SIP::Simple $self = shift; my ($method,@arg) = @_; my $sub = UNIVERSAL::can( 'Net::SIP::Simple::RTP',$method ) || UNIVERSAL::can( 'Net::SIP::Simple::RTP','media_'.$method ) || croak( "no such method '$method' in Net::SIP::Simple::RTP" ); return $sub->( @arg ); } ########################################################################### # Register UA at registrar # waits until final response is received # Args: ($self,%args) # %args: Hash with keys.. # registrar: Register there, default $self->{registrar} # from: use 'from' as lokal address, default $self->{from} # leg: use given Net::SIP::Leg object for registration, default first leg # cb_final: user defined callback when final response is received # more args (expire...) will be forwarded to Net::SIP::Endpoint::register # Returns: expires # if user defined callback or failed expires will be undef # otherwise it will be the expires value from the registrars response ########################################################################### sub register { my Net::SIP::Simple $self = shift; my %args = @_; my $registrar = delete $args{registrar} || $self->{registrar} || croak( "no registrar" ); $registrar = sip_parts2uri(sip_uri2parts($registrar)); # normalize my $leg = delete $args{leg}; if ( !$leg ) { # use first leg which can deliver to registrar ($leg) = $self->{dispatcher}->get_legs( sub => [ sub { my ($addr,$leg) = @_; return $leg->can_deliver_to($addr); }, $registrar ]); } my $from = delete $args{from} || $self->{from} || croak( "unknown from" ); my $contact = delete $args{contact} || $self->{contact}; if ( ! $contact) { $contact = $from; my $local = $leg->laddr(2); $contact.= '@'.$local unless $contact =~s{\@([^\s;,>]+)}{\@$local}; } my %rarg = ( from => $from, registrar => $registrar, contact => $contact, auth => delete $args{auth} || $self->{auth}, ); %rarg = ( %rarg, %args ) if %args; my $cb_final = delete $rarg{cb_final}; my $stopvar = 0; $cb_final ||= \$stopvar; my $cb = sub { my ($self,$cb_final,$expires,$endpoint,$ctx,$errno,$code,$packet,$leg,$from) = @_; if ( $code && $code =~m{^2\d\d} ) { # use expires info on contact # if none given use global expires header # see rfc3261 10.3.8,10.2.4 my $exp; for my $c ( $packet->get_header( 'contact' ) ) { my ($addr,$p) = sip_hdrval2parts( contact => $c ); defined( my $e = $p->{expires} ) or next; sip_uri_eq($addr,$contact) or next; # not me $exp = $e if ! defined($exp) || $e < $exp; } $exp = $packet->get_header( 'Expires' ) if ! defined $exp; $$expires = $exp; invoke_callback( $cb_final, 'OK', expires => $exp, packet => $packet ); } elsif ( $code ) { $self->error( "Failed with code $code" ); invoke_callback( $cb_final, 'FAIL', code => $code, packet => $packet ); } elsif ( $errno ) { $self->error( "Failed with error $errno" ); invoke_callback( $cb_final, 'FAIL', errno => $errno ); } else { $self->error( "Unknown failure" ); invoke_callback( $cb_final, 'FAIL' ); } }; my $expires; $self->{endpoint}->register( %rarg, callback => [ $cb,$self,$cb_final,\$expires ] ); # if cb_final is local stopvar wait until it got set if ( \$stopvar == $cb_final ) { $self->loop( \$stopvar ); return $stopvar eq 'OK' ? $expires: undef; } } ########################################################################### # create new call # and waits until the INVITE is completed (e.g final response received) # Args: ($self,$ctx;%args) # $ctx: \%ctx context describing the call or sip address of peer # %args: see Net::SIP::Simple::Call::invite # Returns: $call # $call: Net::SIP::Simple::Call ########################################################################### sub invite { my Net::SIP::Simple $self = shift; my ($ctx,%args) = @_; (my $to,$ctx) = ref($ctx) ? ($ctx->{to},$ctx) : ($ctx,undef); $to || croak( "need peer of call" ); if ( $to !~m{\s} && $to !~m{\@} ) {; croak( "no domain and no fully qualified to" ) if ! $self->{domain}; my $sip_proto = $self->{dispatcher}->get_legs(proto => 'tls') ? 'sips' : 'sip'; $to = "$to <$sip_proto:$to\@$self->{domain}>"; $ctx->{to} = $to if $ctx; } my $call = Net::SIP::Simple::Call->new( $self,$ctx||$to ); $call->reinvite(%args); return $call; } ########################################################################### # listen for and accept new calls # Args: ($self,%args) # %args: # filter: optional sub or regex to filter which incoming calls gets accepted # if not given all calls will be accepted # if regex only from matching regex gets accepted # if sub and sub returns 1 call gets accepted, if sub returns 0 it gets rejected # cb_create: optional callback called on creation of newly created # Net::SIP::Simple::Call. If returns false the call will be closed. # If returns a callback (e.g some ref) it will be used instead of # Net::SIP::Simple::Call to handle the data # cb_established: callback called after receiving ACK # cb_cleanup: called on destroy of call object # auth_whatever: will require authorization, see whatever in Net::SIP::Authorize # for all other args see Net::SIP::Simple::Call.... # Returns: NONE ########################################################################### sub listen { my Net::SIP::Simple $self = shift; my %args = @_; my $cb_create = delete $args{cb_create}; # handle new requests my $receive = sub { my ($self,$args,$endpoint,$ctx,$request,$leg,$from) = @_; my $method = $request->method; if ( $method eq 'OPTIONS' ) { my $response = $request->create_response( '200','OK',$self->{options} ); $self->{endpoint}->new_response( $ctx,$response,$leg,$from ); $self->{endpoint}->close_context( $ctx ); return; } elsif ( $method ne 'INVITE' ) { DEBUG( 10,"drop non-INVITE request: ".$request->dump ); $self->{endpoint}->close_context( $ctx ); return; } if ( my $filter = $args->{filter} ) { my $rv = invoke_callback( $filter, $ctx->{from},$request ); if ( !$rv ) { DEBUG( 1, "call from '$ctx->{from}' rejected" ); $self->{endpoint}->close_context( $ctx ); return; } } # new invite, create call my $call = Net::SIP::Simple::Call->new( $self,$ctx,{ %$args }); my $cb = UNIVERSAL::can( $call,'receive' ) || die; # notify caller about new call if ($cb_create) { my $cbx = invoke_callback($cb_create, $call, $request, $leg, $from); if ( ! $cbx ) { DEBUG( 1, "call from '$ctx->{from}' rejected in cb_create" ); $self->{endpoint}->close_context( $ctx ); return; } elsif ( ref($cbx) ) { $cb = $cbx } } # setup callback on context and call it for this packet $ctx->set_callback([ $cb,$call ]); $cb->( $call,$endpoint,$ctx,undef,undef,$request,$leg,$from ); }; $self->{endpoint}->set_application( [ $receive,$self,\%args] ); # in case listener should provide authorization put Authorizer in between if ( my $auth = _make_auth_from_args($self,\%args) ) { $self->create_chain([$auth,$self->{endpoint}]); } } ########################################################################### # create authorization if args say so # Args: ($self,$args) # %$args: # auth_user2pass: see user2pass in Net::SIP::Authorize # auth_user2a1: see user2a1 in Net::SIP::Authorize # auth_realm: see realm in Net::SIP::Authorize # auth_.... : see Net::SIP::Authorize # Returns: authorizer if auth_* args given, removes auth_ args from hash ########################################################################## sub _make_auth_from_args { my ($self,$args) = @_; my %auth = map { m{^auth_(.+)} ? ($1 => delete $args->{$_}):() } keys %$args; my $i_am_proxy = delete $auth{i_am_proxy}; return %auth && $self->create_auth(%auth); } ########################################################################### # setup authorization for use in chain # Args: ($self,%args) # %args: see Net::SIP::Authorize # Returns: authorizer object ########################################################################## sub create_auth { my ($self,%args) = @_; return Net::SIP::Authorize->new( dispatcher => $self->{dispatcher}, %args, ); } ########################################################################### # setup a simple registrar # Args: ($self,%args) # %args: # max_expires: maximum expires time accepted fro registration, default 300 # min_expires: minimum expires time accepted, default 30 # domains|domain: domain or \@list of domains the registrar is responsable # for. special domain '*' catches all # auth_whatever: will require authorization, see whatever in Net::SIP::Authorize # Returns: $registrar ########################################################################### sub create_registrar { my Net::SIP::Simple $self = shift; my %args = @_; my $auth = _make_auth_from_args($self,\%args); my $registrar = Net::SIP::Registrar->new( dispatcher => $self->{dispatcher}, %args ); if ( $auth ) { $registrar = $self->create_chain( [$auth,$registrar], methods => ['REGISTER'] ) } else { $self->{dispatcher}->set_receiver( $registrar ); } return $registrar; } ########################################################################### # setup a stateless proxy # Args: ($self,%args) # %args: see Net::SIP::StatelessProxy, for auth_whatever see whatever # in Net::SIP::Authorize # Returns: $proxy ########################################################################### sub create_stateless_proxy { my Net::SIP::Simple $self = shift; my %args = @_; $args{auth_i_am_proxy} = 1; my $auth = _make_auth_from_args($self,\%args); my $proxy = Net::SIP::StatelessProxy->new( dispatcher => $self->{dispatcher}, %args ); if ( $auth ) { $proxy = $self->create_chain([$auth,$proxy]) } else { $self->{dispatcher}->set_receiver($proxy); } return $proxy; } ########################################################################### # setup chain of handlers, e.g. first authorize all requests, everything # else gets handled by stateless proxy etc # Args: ($self,$objects,%args) # Returns: $chain ########################################################################### sub create_chain { my Net::SIP::Simple $self = shift; my $chain = Net::SIP::ReceiveChain->new( @_ ); $self->{dispatcher}->set_receiver( $chain ); return $chain; } 1; Net-SIP-0.822/lib/Net/SIP/Dispatcher/0000755000175100017510000000000013552315100015444 5ustar workworkNet-SIP-0.822/lib/Net/SIP/Dispatcher/Eventloop.pm0000644000175100017510000002242013016115054017756 0ustar workwork ########################################################################### # package Net::SIP::Dispatcher::Eventloop # simple event loop for Net::SIP ########################################################################### use strict; use warnings; package Net::SIP::Dispatcher::Eventloop; use fields qw( fd vec just_dropped timer now ); use Time::HiRes qw(gettimeofday); use Socket; use List::Util qw(first); use Net::SIP::Util ':all'; use Net::SIP::Debug; use Carp 'confess'; use Errno 'EINTR'; # constants for read/write events use Exporter 'import'; our @EXPORT = qw(EV_READ EV_WRITE); use constant EV_READ => 0; use constant EV_WRITE => 1; ########################################################################### # creates new event loop # Args: $class # Returns: $self ########################################################################### sub new { my $class = shift; my $self = fields::new($class); %$self = ( fd => [], # {fd}[fn][rw] -> [fd,callback,name] vec => [ '','' ], # read|write vec(..) for select just_dropped => undef, # dropped fn inside current select timer => [], # list of TimerEvent objects now => scalar(gettimeofday()), # time after select ); return $self; } ########################################################################### # adds callback for the event, that FD is readable # Args: ($self,$fd,$rw,$callback,?$name) # $fd: file descriptor # $rw: if the callback is for read(0) or write(1) # $callback: callback to be called, when fd is readable, will be called # with fd as argument # $name: optional name for callback, used for debugging # Returns: NONE ########################################################################### sub addFD { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($fd,$rw,$callback,$name) = @_; ref($callback) or confess("wrong usage"); defined( my $fn = fileno($fd)) || return; $DEBUG && DEBUG(99, "$self added fn=$fn rw($rw) sock=" . eval { ip_sockaddr2string(getsockname($fd)) }); $self->{fd}[$fn][$rw] = [ $fd,$callback,$name || '' ]; vec($self->{vec}[$rw],$fn,1) = 1; $DEBUG && DEBUG(100, "maxfd=%d",0+@{$self->{fd}}); } ########################################################################### # removes callback for readable for FD # Args: ($self,$fd,?$rw) # $fd: file descriptor # $rw: if disable for read(0) or write(1). Disables both if not given # Returns: NONE ########################################################################### sub delFD { my Net::SIP::Dispatcher::Eventloop $self = shift; my $fd = shift; defined( my $fn = $fd && fileno($fd)) || return; if (!@_) { $DEBUG && DEBUG(99, "$self delete fn=$fn sock=" . eval { ip_sockaddr2string(getsockname($fd)) }); delete $self->{fd}[$fn]; vec($self->{vec}[0],$fn,1) = 0; vec($self->{vec}[1],$fn,1) = 0; # mark both read and write as dropped so we don't process events for the # fd inside the same loop $self->{just_dropped}[$fn] = [1,1] if $self->{just_dropped}; } else { for my $rw (@_) { $DEBUG && DEBUG(99, "$self disable rw($rw) fn=$fn sock=" . eval { ip_sockaddr2string(getsockname($fd)) }); delete $self->{fd}[$fn][$rw]; vec($self->{vec}[$rw],$fn,1) = 0; # mark $rw handler as dropped so we don't process events for the fd # inside the same loop $self->{just_dropped}[$fn][$rw] = 1 if $self->{just_dropped}; } } $DEBUG && DEBUG(100, "maxfd=%d",0+@{$self->{fd}}); } ########################################################################### # add timer # Args: ($self,$when,$callback;$repeat,$name) # $when: absolute time_t or relative (smaller than a year), can be # subsecond resolution # $callback: callback to be called, gets timer object as argument # $repeat: interval for repeated callbacks, optional # $name: optional name for debugging # Returns: $timer object ########################################################################### sub add_timer { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($when,$callback,$repeat,$name ) = @_; $when += $self->{now} if $when < 3600*24*365; my $timer = Net::SIP::Dispatcher::Eventloop::TimerEvent->new( $when, $repeat, $callback,$name ); push @{ $self->{timer}}, $timer; return $timer; } ########################################################################### # return time of currentloop, e.g. when select(2) returned # Args: () # Returns: time ########################################################################### sub looptime { my Net::SIP::Dispatcher::Eventloop $self = shift; return $self->{now} } ########################################################################### # simple mainloop # Args: ($self;$timeout,@stop) # $timeout: if 0 just poll once, if undef never return, otherwise return # after $timeout seconds # @stop: \@array of Scalar-REF, if one gets true the eventloop will be stopped # Returns: NONE ########################################################################### sub loop { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($timeout,@stop) = @_; # looptime for this run my $looptime = $self->{now} = gettimeofday(); # if timeout defined and != 0 set $end to now+timeout # otherwise set end to undef|0 depending on timeout my $end = $timeout ? $looptime + $timeout : $timeout; my $to = $timeout; while ( !$to || $to>0 ) { DEBUG( 100, "timeout = ".( defined($to) ? $to: '' )); # handle timers my $timer = $self->{timer}; my $do_timer = 1; while ( @$timer && $do_timer ) { $do_timer = 0; @$timer = sort { $a->{expire} <=> $b->{expire} } @$timer; # delete canceled timers shift(@$timer) while ( @$timer && !$timer->[0]{expire} ); # run expired timers while ( @$timer && $timer->[0]{expire} <= $looptime ) { my $t = shift(@$timer); DEBUG( 50, "trigger timer(%s) %s repeat=%s", $t->name,$t->{expire} || '', $t->{repeat} || '' ); invoke_callback( $t->{callback},$t ); if ( $t->{expire} && $t->{repeat} ) { $t->{expire} += $t->{repeat}; DEBUG( 100, "timer(%s) gets repeated at %d",$t->name,$t->{expire} ); push @$timer,$t; $do_timer = 1; # rerun loop } } } # adjust timeout for select based on when next timer expires if ( @$timer ) { my $next_timer = $timer->[0]{expire} - $looptime; $to = $next_timer if !defined($to) || $to>$next_timer; } DEBUG( 100, "timeout = ".( defined($to) ? $to: '' )); if ( grep { ${$_} } @stop ) { DEBUG( 50, "stopvar triggered" ); return; } # wait for selected fds my $fds = $self->{fd}; my @vec = @{$self->{vec}}; $DEBUG && DEBUG(100,"BEFORE read=%s write=%s", unpack("b*",$vec[0]), unpack("b*",$vec[1])); my $nfound = select($vec[0],$vec[1], undef, $to); $DEBUG && DEBUG(100,"AFTER read=%s write=%s nfound=%d", unpack("b*",$vec[0]), unpack("b*",$vec[1]), $nfound); if ($nfound<0) { next if $! == EINTR; die $! }; $looptime = $self->{now} = gettimeofday(); $self->{just_dropped} = []; for(my $i=0; $nfound>0 && $i<@$fds; $i++) { next if !$fds->[$i]; for my $rw (0,1) { vec($vec[$rw],$i,1) or next; $nfound--; next if $self->{just_dropped}[$i][$rw]; $DEBUG && DEBUG(50,"call cb on fn=$i rw=$rw ".$fds->[$i][$rw][2]); invoke_callback(@{ $fds->[$i][$rw] }[1,0]); } } if ( defined($timeout)) { last if !$timeout; $to = $end - $looptime; } else { $to = undef } } } ########################################################################## # Timer object which gets returned from add_timer and has method for # canceling the timer (by setting expire to 0) ########################################################################## package Net::SIP::Dispatcher::Eventloop::TimerEvent; use fields qw( expire repeat callback name ); ########################################################################## # create new timer object, see add_timer for description of Args # Args: ($class,$expire,$repeat,$callback) # Returns: $self ########################################################################## sub new { my ($class,$expire,$repeat,$callback,$name) = @_; my $self = fields::new( $class ); unless ( $name ) { # check with caller until I find a function which is not # named 'add_timer' for( my $i=1;1;$i++ ) { my (undef,undef,undef,$sub) = caller($i) or last; next if $sub =~m{::add_timer$}; my $line = (caller($i-1))[2]; $name = "${sub}[$line]"; last; } } %$self = ( expire => $expire, repeat => $repeat, callback => $callback, name => $name ); return $self; } ########################################################################## # cancel timer by setting expire to 0, it will be deleted next time # the timer queue is scanned in loop # Args: $self # Returns: NONE ########################################################################## sub cancel { my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift; $self->{expire} = 0; $self->{callback} = undef; } ########################################################################## # returns name for debugging # Args: $self # Returns: $name ########################################################################## sub name { my Net::SIP::Dispatcher::Eventloop::TimerEvent $self = shift; return $self->{name} || 'NONAME' } 1; Net-SIP-0.822/lib/Net/SIP/Dispatcher/Eventloop.pod0000644000175100017510000001030213205220600020112 0ustar workwork =head1 NAME Net::SIP::Dispatcher::Eventloop - simple event loop for L =head1 SYNOPSIS my $loop = Net::SIP::Dispatcher::Eventloop->new; $loop->addFD( $fd, $callback ); $loop->add_timer( 10,$callback ); $loop->loop; =head1 DESCRIPTION The package implements a simple event loop. It's not optimized for speed but it is provided as a simple implementation in case the users application does not has an event loop yet. Because the eventloop object can be given in the constructor of L you might provide an alternative implementation, which implemented the described methods. =head1 CONSTRUCTOR =over 4 =item new Creates new event loop, returns created object =back =head1 METHODS =over 4 =item addFD (HANDLE, RW, CALLBACK, [NAME]) Adds file handle HANDLE to the event loop, so that CALLBACK gets triggered if HANDLE is readable (B 0) or writeable (B 1). Instead of C<0> and C<1> one can also use the exported constants C and C. CALLBACK is a callback accepted by B in L. The callback will be invoked with HANDLE as an additional argument. NAME can be used to aid debugging, it will be shown in the debug messages once the FD gets ready. If there was already a callback for HANDLE it gets replaced by the new one. IMPORTANT NOTE: CALLBACK gets triggered if HANDLE *is* readable inside the loop, not if HANDLE *gets* readable. Unlike with L or similar the CALLBACK is not triggered by the edge, but by the level (like poll(2) or select(2)). So if 2 bytes come in at the handle and one reads only 1 byte in the callback the callback gets triggered again for more data. You have to watch this, if you want to integrate L with your existing event loop. =item delFD (HANDLE, [RW]) If B is 0 (EV_READ) no more checking for readability of B will be done. If B is 1 (EV_WRITE) no more checking for writeability of B will be done. If B is not given it will remove B from the loop completely, i.e. for both read and write. =item add_timer( WHEN, CALLBACK, [ REPEAT ] ) Adds timer which gets triggered at WHEN or C<< now + WHEN >>. Depending on the value of WHEN it gets interpreted as the number of seconds since 1970-01-01 (when it's really big) or as a relative time (when it's not that big). WHEN can be floating point for subseconds resolution. CALLBACK is a callback accepted by B in L. It gets invoked with the timer object (see later) as an additional argument, which has a method B for canceling the (repeating) timer. REPEAT is the number of seconds between each invocation of the timer. If greater then 0 (subsection resolution possible) the callback will be called each REPEAT seconds, after it was called the first time at WHEN. The method will return an object which has a method B which can be used to cancel the timer before it gets triggered (or gets triggered the next time in case of repeating timers). =item looptime Returns the current loop time in subseconds resolution (using B from L). This is not the current time, but the time, when the last event in the loop occurred (e.g. when the select(2) call returned) =item loop ( [ TIMEOUT, \@STOPVAR ] ) The main loop, e.g. continuiosly checks timers and file handles for the events and calls callbacks. If TIMEOUT is given it will run the loop for at most TIMEOUT seconds, then the method will return. Undefined TIMEOUT means that it will never return because of timeout and TIMEOUT of 0 means that it will check all timers and handles only once and then return. @STOPVAR is a list of scalar references. These scalars are expected to be changed from the callbacks, so it will check after each loop cycle, e.g. after all callbacks are called (timers and handles) if any of these scalars is TRUE, in which case it will end the loop. The behavior with STOPVAR cannot be found in most existing event loops. If you want to integrate L with your own event loop you migth simply wrap all callbacks given in B and B in another callback which at the end checks the stopvars and terminates the 3rd-party loop in a loop-specific way. =back Net-SIP-0.822/lib/Net/SIP/NATHelper/0000755000175100017510000000000013552315100015140 5ustar workworkNet-SIP-0.822/lib/Net/SIP/NATHelper/Client.pod0000644000175100017510000000213311136273030017062 0ustar workwork =head1 NAME Net::SIP::NATHelper::Client - handle NAT/RTP forwarding using remote process =head1 DESCRIPTION This module implements the interface of L but will talk with a remote process based on L while executing the methods. =head1 CONSTRUCTOR =over 4 =item new ( SOCKET ) Will create a new object which will talk with the remote process using the socket SOCKET. SOCKET is either a UNIX domain socket (in SOCK_STREAM mode) or an C specification in which case it will talk TCP through the socket. =back =head1 METHODS It implements the method B, B and B with the same arguments as given in L by calling B with the methods "allocate", "activate" resp. "close". =over 4 =item rpc ( METHOD,@ARG ) Makes a synchronous remote call to the server through the in the constructor specified socket and returns the result. For calling the arguments will be put into a \@list which will be packet using L. A similar way the result comes back. =back Net-SIP-0.822/lib/Net/SIP/NATHelper/Server.pod0000644000175100017510000000500111136273030017107 0ustar workwork =head1 NAME Net::SIP::NATHelper::Server - server for Net::SIP::NATHelper::Client =head1 DESCRIPTION This module is a wrapper around L and will receive it's instructions from L using RPC via sockets. =head1 CONSTRUCTOR =over 4 =item new ( [ HELPER ], @FDS ) Will create an object which listens on all file descriptors given in FDS for RPC from clients. If HELPER is given and a L object or derived it will be used, otherwise the helper will be created. =back =head1 METHODS =over 4 =item do_command ( FD ) Called when FD is available for reading. Calls B on FD and reads the RPC packet from the resulting file descriptor, executes it and returns result back. Currently implemented commands are "allocate","activate" and "close" which will map to the local methods B, B and B. One might redefine or add commands by changing C<< $self->{commands} >>. The key of this hash reference is the command name and the value is the callback. Unknown commands will be ignored, e.g nothing returned. =item loop This will loop over all file descriptors it gets from B in L and the file descriptors for the RPC sockets. When file descriptors gets available for reading it will execute the callbacks, e.g. forward the RTP data or call B. In regular intervals it will call B from L to expire the RTP sockets and sessions. =item allocate_sockets ( ... ) Calls B of the local L object. Takes and returns the same arguments. =item activate_session ( ... ) Calls B of the local L object. Takes the same arguments and returns 1 if the session was newly activated, -1 if it was activated before and false if activation failed. Updates callbacks into the event loop. =item close_session ( ... ) Calls B of the local L object. Takes the same arguments and returns the number of closed sessions. Updates callbacks into the event loop. =item expire ( ... ) Calls B of the local L object. Takes the same arguments and returns the number of expired sessions. Updates callbacks into the event loop if necessary. =back =head1 BUGS The local event loop should be pluggable, so that other implementations could be used. Right now it's a hard coded loop using select. Net-SIP-0.822/lib/Net/SIP/NATHelper/Base.pm0000644000175100017510000010643213552314400016360 0ustar workworkuse strict; use warnings; ############################################################################ # # NATHelper::Base # Helper class for NAT of RTP connections # - allocate sockets for rewriting SDP bodies # - transfer data between sockets within sessions # - close sessions # - expire sockets and sessions on inactivity # ############################################################################ # # ---------------- Base ------------------------------------------------ # | | | | ... # call-id # | # ---------- Call's ----------------------------------- # | | | | ... # idfrom # | # --------------------------------------------- # | | | | ... # cseq # | # ----------------- # | | | # | | socket_group_from: SocketGroup # | | # | socket_groups_to # | | # | |- idto: SocketGroup # | |- idto: SocketGroup # | |- idto: SocketGroup # | |- idto: SocketGroup # | |... # | # sessions # | # |- idto: Session containing 2 x SocketGroup # |- idto: Session containing 2 x SocketGroup # |... # package Net::SIP::NATHelper::Base; use fields qw( calls max_sockets max_sockets_in_group socket_count group_count ); use Net::SIP::Util ':all'; use Net::SIP::Debug; use List::Util qw( first sum ); use Time::HiRes 'gettimeofday'; use Errno 'EMFILE'; use Socket; ############################################################################ # create new Net::SIP::NATHelper::Base # Args: ($class,%args); # Returns: $self ############################################################################ sub new { my ($class,%args) = @_; # Hash of Net::SIP::NATHelper::Call indexed by call-id my $self = fields::new($class); %$self = ( calls => {}, socket_count => 0, group_count => 0, max_sockets => delete $args{max_sockets}, max_sockets_in_group => delete $args{max_sockets_in_group}, ); return $self; } ############################################################################ # create a new call - might be redefined in derived classes to use # other call classes # Args: ($self,$callid) # $callid: call-id # Returns: $call object ############################################################################ sub create_call { Net::SIP::NATHelper::Call->new($_[1]) } ############################################################################ # allocate new sockets for RTP # # Args: ($self,$callid,$cseq,$idfrom,$idto,$side,$addr,\@media) # $callid: call-id # $cseq: sequence number for cseq # $idfrom: ID for from-side # $idto: ID for to-side # $side: 0 if SDP is from request, else 1 # $addr: IP where to create the new sockets # \@media: media like returned from Net::SIP::SDP::get_media # # Returns: $media # $media: \@list of [ip,base_port] of with the size of \@media # # Comment: if it fails () will be returned. In this cases the SIP packet # should not be forwarded (dropped) thus causing a retransmit (for UDP) # which will then cause another call to allocate_sockets and maybe this # time we have enough resources ############################################################################ sub allocate_sockets { my Net::SIP::NATHelper::Base $self = shift; my $callid = shift; my $call = $self->{calls}{$callid} ||= $self->create_call($callid); return $call->allocate_sockets( $self,@_ ); } ############################################################################ # activate session # Args: ($self,$callid,$cseq,$idfrom,$idto;$param) # $callid: call-id # $cseq: sequence number for cseq # $idfrom: ID for from-side # $idto: ID for to-side # $param: user defined param which gets returned from info_as_hash # Returns: ($info,$duplicate) # $info: hash from sessions info_as_hash # $duplicate: TRUE if session was already created # Comment: if it returns FALSE because it fails the SIP packet will not # be forwarded. This is the case on retransmits of really old SIP # packets where the session was already closed ############################################################################ sub activate_session { my Net::SIP::NATHelper::Base $self = shift; my $callid = shift; my $call = $self->{calls}{$callid}; unless ( $call ) { DEBUG( 10,"tried to activate non-existing call $callid" ); return; } return $call->activate_session( @_ ); } ############################################################################ # close session(s) # Args: ($self,$callid,$cseq,$idfrom,$idto) # $callid: call-id # $cseq: optional sequence number, only for CANCEL requests # $idfrom: ID for from-side # $idto: ID for to-side # Returns: @session_info # @session_info: list of hashes from session info_as_hash # Comment: this SIP packet should be forwarded, even if the call # is not known here, because it did not receive the response from # the peer yet (e.g. was retransmit) ############################################################################ sub close_session { my Net::SIP::NATHelper::Base $self = shift; my $callid = shift; my $call = $self->{calls}{$callid}; unless ( $call ) { DEBUG( 10,"tried to close non-existing call $callid" ); return; } return $call->close_session( @_ ); } ############################################################################ # cleanup, e.g. delete expired sessions and unused socket groups # Args: ($self,%args) # %args: hash with the following data # time: current time, will get from gettimeofday() if not given # unused: seconds for timeout of sockets, which were never used in session # defaults to 3 minutes # active: seconds for timeout of sockets used in sessions, defaults to # 30 seconds # Returns: @expired # @expired: list of infos about expired sessions using sessions info_as_hash ############################################################################ sub expire { my Net::SIP::NATHelper::Base $self = shift; my %args = @_; $args{time} ||= gettimeofday(); $args{unused} ||= 3*60; # unused sockets after 3 minutes $args{active} ||= 30; # active sessions after 30 seconds DEBUG( 100,"expire now=$args{time} unused=$args{unused} active=$args{active}" ); my @expired; my $calls = $self->{calls}; foreach my $callid ( keys %$calls ) { my $call = $calls->{$callid}; push @expired, $call->expire( %args ); if ( $call->is_empty ) { DEBUG( 50,"remove call $callid" ); delete $calls->{$callid}; } } return @expired; } ############################################################################ # collect the callbacks for all sessions in all calls # Args: $self # Returns: @callbacks, see *::Session::callbacks ############################################################################ sub callbacks { my Net::SIP::NATHelper::Base $self = shift; return map { $_->callbacks } values %{ $self->{calls} }; } ############################################################################ # run over all sessions and execute callback # Args: $self;$callback # $callback: callback, defaults to simply return the session # Returns: @rv # @rv: array with the return values of all callbacks together ############################################################################ sub sessions { my Net::SIP::NATHelper::Base $self = shift; my $callback = shift; $callback ||= sub { return shift }; # default callback returns session return map { $_->sessions( $callback ) } values %{ $self->{calls} }; } ############################################################################ # Dump debug information into string # Args: $self # Returns: $string ############################################################################ sub dump { my Net::SIP::NATHelper::Base $self = shift; my $result = ""; foreach ( values %{ $self->{calls} } ) { $result.= $_->dump; } return $result; } ############################################################################ # return number of reserved calls # Args: $self # Returns: $n ############################################################################ sub number_of_calls { my Net::SIP::NATHelper::Base $self = shift; return scalar( keys %{ $self->{calls} }) } ############################################################################ # get RTP sockets # can be redefined to allow enforcing of resource limits, caching of # sockets... # right now creates fresh RTP sockets unless max_sockets is reached, # in which case it returns () with $! set to EMFILE # Args: ($self,$new_addr,$media) # $new_addr: IP for new sockets # $media: old media like given from Net::SIP::SDP::get_media # Returns: \@new_media # @new_media: list of [ addr,base_port,\@socks,\@targets] # where addr and base_port are the address and base port for the new # media, @socks the list of sockets and @targets the matching targets # based on the original media ############################################################################ sub get_rtp_sockets { my Net::SIP::NATHelper::Base $self = shift; my ($new_addr,$media) = @_; my @new_media; my $need_sockets = sum( map { $_->{range} } @$media ); if ( my $max = $self->{max_sockets_in_group} ) { if ( $need_sockets > $max ) { DEBUG( 1,"allocation of RTP sockets denied because max_sockets_in_group limit reached" ); $! = EMFILE; return; } } if ( my $max = $self->{max_sockets} ) { if ( $self->{socket_count} + $need_sockets > $max ) { DEBUG( 1,"allocation of RTP sockets denied because max_sockets limit reached" ); $! = EMFILE; return; } } foreach my $m (@$media) { my ($addr,$port,$range) = @{$m}{qw/addr port range/}; # allocate new sockets my ($new_port,@socks) = create_rtp_sockets( $new_addr,$range ); unless (@socks) { DEBUG( 1,"allocation of RTP sockets failed: $!" ); return; } if (!$port or $addr eq '0.0.0.0' or $addr eq '::') { # RFC 3264 6.1 - stream marked as inactive DEBUG(50,"inactive stream" ); push @new_media, [ $new_addr,0,\@socks, # no target for socket on other side [ map { undef } (0..$#socks) ] ]; } else { DEBUG( 100,"m_old=$addr $port/$range new_port=$new_port" ); push @new_media, [ $new_addr,$new_port,\@socks, # target for sock on other side is original address [ map { ip_parts2sockaddr($addr,$port+$_) } (0..$#socks) ] ] } } $self->{socket_count} += $need_sockets; $self->{group_count} ++; return \@new_media; } ############################################################################ # free created RTP sockets # Args: $self,$media # $media: see return code from get_rtp_sockets # Returns: NONE ############################################################################ sub unget_rtp_sockets { my Net::SIP::NATHelper::Base $self = shift; my $media = shift; $self->{group_count} --; $self->{socket_count} -= sum( map { int(@{ $_->[2] }) } @$media ); } ############################################################################ ############################################################################ # # Net::SIP::NATHelper::Call # manages Call, e.g. for each active cseq for the same call-id # it manages the Net::SIP::NATHelper::SocketGroup's and Net::SIP::NATHelper::Session's # ############################################################################ ############################################################################ package Net::SIP::NATHelper::Call; use fields qw( callid from ); use Hash::Util 'lock_keys'; use List::Util 'max'; use Net::SIP::Debug; use Net::SIP::Util 'invoke_callback'; sub new { my ($class,$callid) = @_; my $self = fields::new($class); %$self = ( callid => $callid, from => {}, ); return $self; } ############################################################################ # allocate sockets for rewriting SDP body # Args: ($nathelper,$self,$cseq,$idfrom,$idto,$side,$addr,$media) # Returns: $media ############################################################################ sub allocate_sockets { my Net::SIP::NATHelper::Call $self = shift; my ($nathelper,$cseq,$idfrom,$idto,$side,$addr,$media) = @_; # find existing data for $idfrom,$cseq my $cseq_data = $self->{from}{$idfrom}; my $data = $cseq_data && $cseq_data->{$cseq}; if ( ! $data ) { # if it is not known check if cseq is too small (retransmit of old packet) if ( $cseq_data ) { foreach ( keys %$cseq_data ) { if ( $_ > $cseq ) { DEBUG( 10,"retransmit? cseq $cseq is smaller than $_ in call $self->{callid}" ); return; } } } # need new record $cseq_data ||= $self->{from}{$idfrom} = {}; $data = $cseq_data->{$cseq} = { socket_group_from => undef, socket_groups_to => {}, # indexed by idto sessions => {}, # indexed by idto }; lock_keys( %$data ); } # if SocketGroup already exists return it's media # otherwise try to create a new one # if this fails return (), otherwise return media my $sgroup; if ( $side == 0 ) { # FROM $sgroup = $data->{socket_group_from} ||= do { DEBUG( 10,"new socketgroup with idfrom $idfrom" ); Net::SIP::NATHelper::SocketGroup->new( $nathelper,$idfrom,$addr,$media ) || return; }; } else { $sgroup = $data->{socket_groups_to}{$idto} ||= do { DEBUG( 10,"new socketgroup with idto $idto" ); Net::SIP::NATHelper::SocketGroup->new( $nathelper,$idto,$addr,$media ) || return; }; } return $sgroup->get_media; } ############################################################################ # activate session # Args: ($self,$cseq,$idfrom,$idto;$param) # Returns: ($info,$duplicate) ############################################################################ sub activate_session { my Net::SIP::NATHelper::Call $self = shift; my ($cseq,$idfrom,$idto,$param) = @_; my $by_cseq = $self->{from}{$idfrom}; my $data = $by_cseq && $by_cseq->{$cseq}; unless ( $data ) { DEBUG( 10,"tried to activate non-existing session $idfrom|$cseq in call $self->{callid}" ); return; } my $sessions = $data->{sessions}; if ( my $sess = $sessions->{$idto} ) { # exists already, maybe retransmit of ACK return ( $sess->info_as_hash( $self->{callid},$cseq ), 1 ); } my $gfrom = $data->{socket_group_from}; my $gto = $data->{socket_groups_to}{$idto}; if ( !$gfrom || !$gto ) { DEBUG( 50,"session $self->{callid},$cseq $idfrom -> $idto not complete " ); return; } my $sess = $sessions->{$idto} = $self->create_session( $gfrom,$gto,$param ); DEBUG( 10,"new session {$sess->{id}} $self->{callid},$cseq $idfrom -> $idto" ); return ( $sess->info_as_hash( $self->{callid},$cseq ), 0 ); } ############################################################################ # create Session object # Args: ($self,$gfrom,$gto,$param) # $gfrom: socket group on from-side # $gto: socket group on to-side # $param: optional session parameter (see Base::activate_session) # Reuturns: $session object ############################################################################ sub create_session { shift; return Net::SIP::NATHelper::Session->new(@_) } ############################################################################ # close session # Args: ($self,$cseq,$idfrom,$idto) # $cseq: optional sequence number, only for CANCEL requests # Returns: @session_info # @session_info: list of infos of all closed sessions, info is hash with # callid,cseq,idfrom,idto,from,to,bytes_from,bytes_to ############################################################################ sub close_session { my Net::SIP::NATHelper::Call $self = shift; my ($cseq,$idfrom,$idto) = @_; #DEBUG( 100,$self->dump ); my @info; if ( $cseq ) { # close initiated by CANCEL orr ACK to 401 my $data = $self->{from}{$idfrom}; $data = $data && $data->{$cseq}; if (my $sess = $data && delete( $data->{sessions}{$idto} )) { push @info, $sess->info_as_hash( $self->{callid},$cseq ); DEBUG( 10,"close session {$sess->{id}} $self->{callid}|$cseq $idfrom -> $idto success" ); } else { DEBUG( 10,"tried to CANCEL non existing session in $self->{callid}|$cseq" ); } if ($data && !%{$data->{sessions}}) { %{$data->{socket_groups_to}} = (); $data->{socket_group_from} = undef; DEBUG( 10,"cancel sessions $self->{callid}|$cseq $idfrom -> $idfrom - no more sessions" ); delete $self->{from}{$idfrom}{$cseq}; } } else { # close from BYE (which has different cseq then the INVITE) # need to close all sessions between idfrom and idto, because BYE could # originate by UAC or UAS foreach my $pair ( [ $idfrom,$idto ],[ $idto,$idfrom ] ) { my ($from,$to) = @$pair; my $by_cseq = $self->{from}{$from} || next; my @del_cseq; while (my ($cseq,$data) = each %$by_cseq) { if (my $sess = delete $data->{sessions}{$to}) { push @info, $sess->info_as_hash( $self->{callid},$cseq ); DEBUG( 10,"close session {$sess->{id}} $self->{callid}|$cseq $idfrom -> $idto " ); } if (!%{$data->{sessions}}) { %{$data->{socket_groups_to}} = (); $data->{socket_group_from} = undef; DEBUG( 10,"bye sessions $self->{callid}|$cseq $idfrom -> $idto - no more sessions" ); push @del_cseq, $cseq; } } delete @{$by_cseq}{@del_cseq} if @del_cseq; } unless (@info) { DEBUG( 10,"tried to BYE non existing session in $self->{callid}" ); return; } DEBUG( 10,"close sessions $self->{callid} $idfrom -> $idto success" ); } return @info; } ############################################################################ # expire call, e.g. inactive sessions, unused socketgroups... # Args: ($self,%args) # %args: see *::Base::expire # Returns: @expired # @expired: list of infos about expired sessions containing, see # close_session ############################################################################ sub expire { my Net::SIP::NATHelper::Call $self = shift; my %args = @_; my $expire_unused = $args{time} - $args{unused}; my $expire_active = $args{time} - $args{active}; my @expired; my %active_pairs; # mapping [idfrom,idto]|[idto,idfrom] -> session.created my $need_next_pass; my $by_from = $self->{from}; for my $pass (1,2) { while ( my ($idfrom,$by_cseq) = each %$by_from ) { # start with highest cseq so that we hopefully need 2 passes # for expire session which got replaced by new ones my @cseq = sort { $b <=> $a } keys %$by_cseq; foreach my $cseq ( @cseq ) { my $data = $by_cseq->{$cseq}; # drop inactive sessions my $sessions = $data->{sessions}; foreach my $idto ( keys %$sessions ) { my $sess = $sessions->{$idto}; my $lastmod = max($sess->lastmod,$sess->{created}); if ( $lastmod < $expire_active ) { DEBUG( 10,"$self->{callid} expired session {$sess->{id}} $cseq|$idfrom|$idto because lastmod($lastmod) < active($expire_active)" ); my $sess = delete $sessions->{$idto}; push @expired, $sess->info_as_hash( $self->{callid}, $cseq, reason => 'expired' ); } elsif ( my $created = max( $active_pairs{ "$idfrom\0$idto" } || 0, $active_pairs{ "$idto\0$idfrom" } || 0 ) ) { if ( $created > $sess->{created} ) { DEBUG( 10,"$self->{callid} removed session {$sess->{id}} $cseq|$idfrom|$idto because there is newer session" ); my $sess = delete $sessions->{$idto}; push @expired, $sess->info_as_hash( $self->{callid}, $cseq, reason => 'replaced' ); } elsif ( $created < $sess->{created} ) { # probably a session in the other direction has started DEBUG( 100,"there is another session with created=$created which should be removed in next pass" ); $active_pairs{ "$idfrom\0$idto" } = $sess->{created}; $need_next_pass = 1 } } else { # keep session DEBUG( 100,"$self->{callid} session {$sess->{id}} $idfrom -> $idto created=$sess->{created} stays active in pass#$pass" ); $active_pairs{ "$idfrom\0$idto" } = $sess->{created}; } } # delete socketgroups, which are not used in sessions and which # are expired # use string representation as key for comparison my %used; foreach ( values %$sessions ) { $used{ $_->{sfrom} }++; $used{ $_->{sto} }++; } my $groups = $data->{socket_groups_to}; my %expired_sg; my @v = values(%$groups); push @v,$data->{socket_group_from} if $data->{socket_group_from}; foreach my $v ( @v ) { next if $used{ $v }; # used in not expired session my $lastmod = $v->{lastmod}; if ( ! $lastmod ) { # was never used if ( $v->{created} < $expire_unused ) { DEBUG( 10,"$self->{callid} expired socketgroup $v->{id} because created($v->{created}) < unused($expire_unused)" ); $expired_sg{$v} = 1; } } elsif ( $lastmod < $expire_active ) { DEBUG( 10,"$self->{callid} expired socketgroup $v->{id} because lastmod($lastmod) < active($expire_active)" ); $expired_sg{$v} = 1; } } $data->{socket_group_from} = undef if %expired_sg and delete( $expired_sg{ $data->{socket_group_from} } ); if ( %expired_sg ) { foreach my $id (keys(%$groups)) { delete $groups->{$id} if delete $expired_sg{$groups->{$id}}; %expired_sg || last; } } } } # only run again if needed $need_next_pass || last; $need_next_pass = 0; DEBUG( 100,'need another pass' ); } return @expired; } ############################################################################ # check if empty, e.g. no more socket groups on the call # Args: $self # Returns: TRUE if empty ############################################################################ sub is_empty { my Net::SIP::NATHelper::Call $self = shift; my $by_from = $self->{from}; foreach my $idfrom ( keys %$by_from ) { my $by_cseq = $by_from->{$idfrom}; foreach my $cseq ( keys %$by_cseq ) { my $data = $by_cseq->{$cseq}; if ( ! %{ $data->{socket_groups_to}} && ! $data->{socket_group_from} ) { DEBUG( 100,"deleted unused cseq $cseq in $self->{callid}|$idfrom" ); delete $by_cseq->{$cseq}; } } if ( ! %$by_cseq ) { DEBUG( 100,"deleted unused idfrom $idfrom in $self->{callid}" ); delete $by_from->{$idfrom}; } } return %$by_from ? 0:1; } ############################################################################ # collect the callbacks for all sessions within the call # Args: $self # Returns: @callbacks, see Net::SIP::NATHelper::Session::callbacks ############################################################################ sub callbacks { my Net::SIP::NATHelper::Call $self = shift; my @cb; my $by_from = $self->{from}; foreach my $by_cseq ( values %$by_from ) { foreach my $data ( values %$by_cseq ) { push @cb, map { $_->callbacks } values %{ $data->{sessions} }; } } return @cb; } ############################################################################ # run over all session and execte callback # Args: $self,$callback # Returns: @rv # @rv: results of all callback invocations together ############################################################################ sub sessions { my Net::SIP::NATHelper::Call $self = shift; my $callback = shift; my $by_from = $self->{from}; my @rv; foreach my $by_cseq ( values %$by_from ) { foreach my $data ( values %$by_cseq ) { push @rv, map { invoke_callback($callback,$_) } values %{ $data->{sessions} }; } } return @rv; } ############################################################################ # Dump debug information into string # Args: $self # Returns: $string ############################################################################ sub dump { my Net::SIP::NATHelper::Call $self = shift; my $result = "-- DUMP of call $self->{callid} --\n"; my $by_from = $self->{from}; foreach my $idfrom ( sort keys %$by_from ) { my $by_cseq = $by_from->{$idfrom}; foreach ( sort { $a <=> $b } keys %$by_cseq ) { $result.= "-- Socket groups in $idfrom|$_ --\n"; my $sgroups = $by_cseq->{$_}{socket_groups_to}; my $sf = $by_cseq->{$_}{socket_group_from}; $result .= $sf->dump if $sf; foreach ( sort keys %$sgroups ) { $result.= $sgroups->{$_}->dump; } $result.= "-- Sessions in $idfrom|$_ --\n"; my $sessions = $by_cseq->{$_}{sessions}; foreach ( sort keys %$sessions ) { $result.= $sessions->{$_}->dump; } } } return $result; } ############################################################################ ############################################################################ # # Net::SIP::NATHelper::Session # each session consists of two Net::SIP::NATHelper::SocketGroup's and the data # are transferred between these groups # ############################################################################ ############################################################################ package Net::SIP::NATHelper::Session; use fields qw( sfrom sto created bytes_from bytes_to callbacks id param ); use Net::SIP::Debug; use List::Util 'max'; use Net::SIP::Util ':all'; use Time::HiRes 'gettimeofday'; # increased for each new session my $session_id = 0; ############################################################################ # create new Session between two SocketGroup's # Args: ($class,$socketgroup_from,$socketgroup_to;$param) # Returns: $self ############################################################################ sub new { my ($class,$sfrom,$sto,$param) = @_; my $self = fields::new( $class ); # sanity check that both use the same number of sockets if ( @{ $sfrom->get_socks } != @{ $sto->get_socks } ) { DEBUG( 1,"different number of sockets in request and response" ); return; } %$self = ( sfrom => $sfrom, sto => $sto, created => scalar( gettimeofday() ), bytes_from => 0, bytes_to => 0, callbacks => undef, param => $param, id => ++$session_id, ); return $self; } ############################################################################ # returns session info as hash # Args: ($self,$callid,$cseq,%more) # %more: hash with more key,values to put into info # Returns: %session_info # %session_info: hash with callid,cseq,idfrom,idto,from,to, # bytes_from,bytes_to,sessionid and %more ############################################################################ sub info_as_hash { my Net::SIP::NATHelper::Session $self = shift; my ($callid,$cseq,%more) = @_; my $from = join( ",", map { "$_->{addr}:$_->{port}/$_->{range}" } @{ $self->{sfrom}{orig_media} } ); my $to = join( ",", map { "$_->{addr}:$_->{port}/$_->{range}" } @{ $self->{sto}{orig_media} } ); return { callid => $callid, cseq => $cseq, idfrom => $self->{sfrom}{id}, idto => $self->{sto}{id}, from => $from, to => $to, bytes_from => $self->{bytes_from}, bytes_to => $self->{bytes_to}, created => $self->{created}, sessionid => $self->{id}, param => $self->{param}, %more, } } ############################################################################ # return time of last modification, e.g. maximum of lastmod of both # socketgroups # Args: $self # Returns: $lastmod ############################################################################ sub lastmod { my Net::SIP::NATHelper::Session $self = shift; return max( $self->{sfrom}{lastmod}, $self->{sto}{lastmod} ); } ############################################################################ # return all [ socket, callback,cbid ] tuples for the session # cbid is uniq for each callback and can be used to detect, which callbacks # changed compared to the last call # Args: $self # Returns: @callbacks ############################################################################ my $callback_id = 0; # uniq id for each callback sub callbacks { my Net::SIP::NATHelper::Session $self = shift; my $callbacks = $self->{callbacks}; return @$callbacks if $callbacks; # already computed # data received on sockets in $sfrom will be forwarded to the original # target from $sfrom using the matching socket from $sto and the other # way around. # This means we do symetric RTP in all cases my $sfrom = $self->{sfrom}; my $sockets_from = $sfrom->get_socks; my $targets_from = $sfrom->get_targets; my $sto = $self->{sto}; my $sockets_to = $sto->get_socks; my $targets_to = $sto->get_targets; my $fwd_data = $self->can('forward_data'); my @cb; for( my $i=0;$i<@$sockets_from;$i++ ) { # If we detect, that the peer does symmetric RTP we connect the # socket and set the addr to undef to make sure that we use send # and not sendto when forwarding the data my $recvaddr = $targets_to->[$i]; my $dstaddr = $targets_from->[$i]; $dstaddr && push @cb, [ $sockets_from->[$i], [ $fwd_data, $sockets_from->[$i], # read data from socket FROM(nat) $sockets_to->[$i], # forward them using socket TO(nat) \$recvaddr,\$dstaddr, # will be set to undef once connected $sfrom, # call $sfrom->didit \$self->{bytes_to}, # to count bytes coming from 'to' $self->{id}, # for debug messages ], ++$callback_id ]; $recvaddr && push @cb, [ $sockets_to->[$i], [ $fwd_data, $sockets_to->[$i], # read data from socket TO(nat) $sockets_from->[$i], # forward data using socket FROM(nat) \$dstaddr,\$recvaddr, # will be set to undef once connected $sto, # call $sto->didit \$self->{bytes_from}, # to count bytes coming from 'from' $self->{id}, # for debug messages ], ++$callback_id ]; } $self->{callbacks} = \@cb; # cache return @cb; } ############################################################################ # function used for forwarding data in callbacks() ############################################################################ sub forward_data { my ($read_socket,$write_socket,$rfrom,$rto,$group,$bytes,$id) = @_; my $peer = recv( $read_socket, my $buf,2**16,0 ) || do { DEBUG( 10,"recv data failed: $!" ); return; }; my $name = sub { ip_sockaddr2string(shift) }; if ( ! $$bytes ) { if ( $peer eq $$rfrom ) { DEBUG( 10,"peer ".$name->($peer). " uses symmetric RTP, connecting sockets"); $$rfrom = undef if connect($read_socket,$peer); } else { # set rfrom to peer for later checks $$rfrom = $peer; } } elsif ( $$rfrom && $peer ne $$rfrom ) { # the previous packet was from another peer, ignore this data DEBUG( 10,"{$id} ignoring unexpected data from %s on %s, expecting data from %s instead", $name->($peer), $name->(getsockname($read_socket)),$name->($$rfrom)); } my $l = length($buf); $$bytes += $l; $group->didit($l); if ( $$rto ) { send( $write_socket, $buf,0, $$rto ) || do { DEBUG( 10,"send data failed: $!" ); return; }; DEBUG( 50,"{$id} transferred %d bytes on %s via %s to %s", length($buf), $name->( getsockname($read_socket )), $name->(getsockname( $write_socket )),$name->($$rto)); } else { # using connected socket send( $write_socket, $buf,0 ) || do { DEBUG( 10,"send data failed: $!" ); return; }; DEBUG( 50,"{$id} transferred %d bytes on %s via %s to %s", length($buf), $name->( getsockname($read_socket )), $name->(getsockname( $write_socket )), $name->(getpeername( $write_socket ))); } } ############################################################################ # Dump debug information into string # Args: $self # Returns: $string ############################################################################ sub dump { my Net::SIP::NATHelper::Session $self = shift; return "{$self->{id}}". ( $self->{sfrom} && $self->{sfrom}{id} || 'NO.SFROM' ).",". ( $self->{sto} && $self->{sto}{id} || 'NO.STO' )."\n"; } ############################################################################ ############################################################################ # # Net::SIP::NATHelper::SocketGroup # manages groups of sockets created from an SDP body # manages the local (NAT) sockets and the original targets from the SDP # ############################################################################ ############################################################################ package Net::SIP::NATHelper::SocketGroup; use fields qw( id created lastmod new_media orig_media nathelper ); use Net::SIP::Debug; use Time::HiRes 'gettimeofday'; use Socket; ############################################################################ # create new socket group based on the original media and a local address # Args: ($class,$nathelper,$id,$new_addr,$media) # Returns: $self|() # Comment: () will be returned if allocation of sockets fails ############################################################################ sub new { my ($class,$nathelper,$id,$new_addr,$media) = @_; my $new_media = $nathelper->get_rtp_sockets( $new_addr,$media ) or return; my $self = fields::new($class); %$self = ( nathelper => $nathelper, id => $id, orig_media => [ @$media ], new_media => $new_media, lastmod => 0, created => scalar( gettimeofday() ), ); return $self; } ############################################################################ # give allocated sockets back to NATHelper ############################################################################ sub DESTROY { my Net::SIP::NATHelper::SocketGroup $self = shift; ($self->{nathelper} || return )->unget_rtp_sockets( $self->{new_media} ) } ############################################################################ # updates timestamp of last modification, used in expiring # Args: ($self) # Returns: NONE ############################################################################ sub didit { my Net::SIP::NATHelper::SocketGroup $self = shift; $self->{lastmod} = gettimeofday(); } ############################################################################ # returns \@list of media [ip,port,range] in group # Args: $self # Returns: \@media ############################################################################ sub get_media { my Net::SIP::NATHelper::SocketGroup $self = shift; my @media = map { [ $_->[0], # addr $_->[1], # base port int(@{$_->[2]}) # range, e.g number of sockets ]} @{ $self->{new_media} }; return \@media; } ############################################################################ # returns \@list of sockets in group # Args: $self # Returns: \@sockets ############################################################################ sub get_socks { my Net::SIP::NATHelper::SocketGroup $self = shift; return [ map { @{$_->[2]} } @{$self->{new_media}} ]; } ############################################################################ # returns \@list of the original targets in group # Args: $self # Returns: \@targets ############################################################################ sub get_targets { my Net::SIP::NATHelper::SocketGroup $self = shift; return [ map { @{$_->[3]} } @{$self->{new_media}} ]; } ############################################################################ # Dump debug information into string # Args: $self # Returns: $string ############################################################################ sub dump { my Net::SIP::NATHelper::SocketGroup $self = shift; my $result = $self->{id}." >> ".join( ' ', map { "$_->[0]:$_->[1]/$_->[2]" } @{$self->get_media} ). "\n"; return $result; } 1; Net-SIP-0.822/lib/Net/SIP/NATHelper/Server.pm0000644000175100017510000001325412271422677016770 0ustar workworkuse strict; use warnings; ############################################################################ # # wrap Net::SIP::NATHelper::Base # read commands from socket and propagete them to NATHelper, send # replies back # ############################################################################ package Net::SIP::NATHelper::Server; use fields qw( helper callbacks cfd commands ); use Net::SIP qw(invoke_callback :debug); use Net::SIP::NATHelper::Base; use Storable qw(thaw nfreeze); use Data::Dumper; my %default_commands = ( allocate => sub { shift->allocate_sockets(@_) }, activate => sub { shift->activate_session(@_) }, close => sub { shift->close_session(@_) }, ); ############################################################################ # new NAThelper # Args: ($class,?$helper,@socket) # $helper: Net::SIP::NATHelper::Base object, will be created if not given # @socket: SOCK_STREAM sockets for communication SIP proxies # Returns: $self ############################################################################ sub new { my $class = shift; my $helper; if ( @_ && UNIVERSAL::isa( $_[0],'Net::SIP::NATHelper::Base' )) { $helper = shift; } else { $helper = Net::SIP::NATHelper::Base->new; } my $self = fields::new( $class ); %$self = ( helper => $helper, callbacks => [], cfd => \@_, commands => { %default_commands }, ); return $self, } ############################################################################ # read + execute command # command is transported as [ $cmd,@args ] using Storable::nfreeze # and reply is transported back using nfreeze too # Args: $self # Returns: NONE ############################################################################ sub do_command { my Net::SIP::NATHelper::Server $self = shift; my $cfd = shift; my $sock = $cfd->accept || do { DEBUG( 50,"accept failed: $!" ); return; }; $sock->autoflush; read( $sock,my $buf, 4 ) || do { DEBUG( 50, "read of 4 bytes len failed: $!" ); return; }; my $len = unpack( "N",$buf ); DEBUG( 50, "len=$len" ); if ( $len > 32768 ) { warn( "tooo much data to read, unbelievable len=$len" ); return; } read( $sock,$buf, $len ) || do { DEBUG( 50,"read of $len bytes failed: $!" ); return; }; my ($cmd,@args) = eval { @{ thaw( $buf ) } } or do { DEBUG( 50,"thaw failed: $@" ); return; }; DEBUG( 100, "request=".Dumper([$cmd,@args])); my $cb = $self->{commands}{$cmd} or do { DEBUG( 10,"unknown command: $cmd" ); return; }; my $reply = invoke_callback($cb,$self,@args); unless ( defined( $reply )) { DEBUG( 10, "no reply for $cmd" ); } DEBUG( 100, "reply=".Dumper($reply)); # nfreeze needs reference! print $sock pack( "N/a*",nfreeze(\$reply)); close($sock); } ############################################################################ # loop: # * if received new command execute it # * if receive data on RTP sockets forward them # Args: $self # Returns: NEVER ############################################################################ sub loop { my Net::SIP::NATHelper::Server $self = shift; my $rin; # select mask my $last_expire = 0; my $helper = $self->{helper}; while (1) { # @$callbacks get set to empty in _update_callbacks which get # called if something on the sockets changed. In this case # recompute the callbacks. This is not the fastest method, but # easy to understand :) my $callbacks = $self->{callbacks}; my $timeout = 1; if ( !@$callbacks ) { # recompute callbacks: # - add callbacks from NATHelper foreach ( $helper->callbacks ) { my ($fd,$cb) = @$_; $callbacks->[ fileno($fd) ] = $cb; } # if nothing to do on helper set timeout to infinite if ( !@$callbacks && ! $helper->number_of_calls ) { $timeout = undef; DEBUG( 50,"no RTP socks: set timeout to infinite" ); } # - and for command sockets foreach my $cfd ( @{ $self->{cfd} } ) { $callbacks->[ fileno($cfd) ] = [ \&do_command, $self,$cfd ]; } # recompute select mask $rin = ''; for( my $i=0;$i<@$callbacks;$i++ ) { vec( $rin,$i,1 ) = 1 if $callbacks->[$i] } } # select which sockets got readable or timeout $rin || die; defined( select( my $rout = $rin,undef,undef,$timeout ) ) || die $!; my $now = time(); # handle callbacks on sockets if ( $rout ) { for( my $i=0;$i<@$callbacks;$i++ ) { invoke_callback( $callbacks->[$i] ) if vec( $rout,$i,1 ); } } # handle expires if ( $now - $last_expire >= 1 ) { $last_expire = $now; $self->expire; DEBUG( 100, $helper->dump ); } } } ############################################################################ # wrap methods in helper to call _update_callbacks when appropriate ############################################################################ sub expire { my Net::SIP::NATHelper::Server $self = shift; my @expired = $self->{helper}->expire(@_); @expired && $self->_update_callbacks; return int(@expired); } sub allocate_sockets { my Net::SIP::NATHelper::Server $self = shift; my $media = $self->{helper}->allocate_sockets(@_) || return; #$self->_update_callbacks; return $media; } sub activate_session { my Net::SIP::NATHelper::Server $self = shift; my ($info,$duplicate) = $self->{helper}->activate_session(@_) or return; $self->_update_callbacks; return $duplicate ? -1:1; } sub close_session { my Net::SIP::NATHelper::Server $self = shift; my @info = $self->{helper}->close_session(@_) or return; $self->_update_callbacks; return scalar(@info); } sub _update_callbacks { my Net::SIP::NATHelper::Server $self = shift; @{ $self->{callbacks} } = (); } 1; Net-SIP-0.822/lib/Net/SIP/NATHelper/Local.pod0000644000175100017510000000251311136273030016700 0ustar workwork =head1 NAME Net::SIP::NATHelper::Local - handle NAT/RTP forwarding in local event loop. =head1 DESCRIPTION This module is a wrapper around L which will handle the RTP forwarding within the local event loop the rest of L uses. =head1 CONSTRUCTOR =over 4 =item new ( LOOP ) Will create the object and tell it to use LOOP as the event loop. Will create a L object which gets used internally. =back =head1 METHODS =over 4 =item allocate_sockets ( ... ) Calls B of the local L object. Takes and returns the same arguments. =item activate_session ( ... ) Calls B of the local L object. Takes the same arguments and returns 1 if the session was newly activated, -1 if it was activated before and false if activation failed. Updates callbacks into the event loop. =item close_session ( ... ) Calls B of the local L object. Takes the same arguments and returns the number of closed sessions. Updates callbacks into the event loop. =item expire ( ... ) Calls B of the local L object. Takes the same arguments and returns the number of expired sessions. Updates callbacks into the event loop if necessary. =back Net-SIP-0.822/lib/Net/SIP/NATHelper/Local.pm0000644000175100017510000000411313243252120016526 0ustar workworkuse strict; use warnings; ############################################################################ # # Net::SIP::NATHelper::Local # wrapper around Net::SIP::NATHelper::Base to integrate into local mainloop # ############################################################################ package Net::SIP::NATHelper::Local; use Net::SIP::Debug; use Net::SIP::NATHelper::Base; use Net::SIP::Dispatcher::Eventloop; use fields qw( helper loop callbacks ); sub new { my ($class,$loop) = @_; my $self = fields::new($class); my $helper = Net::SIP::NATHelper::Base->new; %$self = ( loop => $loop, helper => $helper, callbacks => [] ); $loop->add_timer( 1, [ sub { shift->expire },$self ], 1, 'nat_expire' ); return $self; } sub expire { my Net::SIP::NATHelper::Local $self = shift; my @expired = $self->{helper}->expire(@_); @expired && $self->_update_callbacks; return int(@expired); } sub allocate_sockets { my Net::SIP::NATHelper::Local $self = shift; my $media = $self->{helper}->allocate_sockets(@_) || return; #$self->_update_callbacks; return $media; } sub activate_session { my Net::SIP::NATHelper::Local $self = shift; my ($info,$duplicate) = $self->{helper}->activate_session(@_) or return; $self->_update_callbacks; return $duplicate ? -1:1; } sub close_session { my Net::SIP::NATHelper::Local $self = shift; my @info = $self->{helper}->close_session(@_) or return; $self->_update_callbacks; return scalar(@info); } sub _update_callbacks { my Net::SIP::NATHelper::Local $self = shift; my $cb_old = $self->{callbacks}; my @cb_new = $self->{helper}->callbacks; $self->{callbacks} = \@cb_new; # hash by cbid for old callbacks my %old = map { $_->[2] => $_ } @{ $cb_old || [] }; my $loop = $self->{loop}; foreach my $cb ( @cb_new ) { my ($socket,$callback,$id) = @$cb; if ( delete $old{ $id } ) { # unchanged } else { # new callback $loop->addFD($socket, EV_READ, $callback) } } # delete unused callbacks map { $loop->delFD( $_->[0] ) } values %old; } 1; Net-SIP-0.822/lib/Net/SIP/NATHelper/Base.pod0000644000175100017510000001530513005561434016530 0ustar workwork =head1 NAME Net::SIP::NATHelper::Base - rewrite SDP and transport RTP for NAT =head1 DESCRIPTION This module helps with doing NAT. It is implicitly used in B from L. It cares about the rewriting the SDP bodies, forwarding RTP data for active sessions and expiring sessions. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) Creates a new object. %ARGS can be of: =over 8 =item max_sockets N Restricts the maximum number of sockets allocated inside the object to N. =item max_sockets_in_group N Restricts the maximum number of sockets allocated for a single socket group (e.g. a single call to B) to N. =back =back =head1 METHODS =over 4 =item allocate_sockets ( CALLID,CSEQ,IDFROM,IDTO,SIDE,ADDR,MEDIA ) This is called to allocate new local sockets for MEDIA. MEDIA is a \@list of specifications like you get from B in L. ADDR is the local address, where the sockets should be allocated. IDFROM and IDTO represent the sides of the session, while SIDE helps to pick the right side for allocation, e.g. if SIDE is 0 the sockets will be allocated on the IDFROM side, if it is 1 it will be on the IDTO side. Thus for Requests SIDE will be 0, while for responses it will be 1. CALLID and CSEQ are used to identify the SIP transaction, for which the NAT will be done, while IDSIDE is either IDFROM or IDTO (see below) depending on the side, where the packet came in. The methode will return the \@list of new media in the format needed by B in L, e.g tuples of C<[ip,base_port]>. If the allocation of sockets failed (because of resource constraints) it will return undef. This will usually cause the caller do simply not forward the packet and wait for the reetransmit (at least for UDP). =item activate_session ( CALLID,CSEQ,IDFROM,IDTO,[\%PARAM] ) Activates a session in the transaction defined by CALLID,CSEQ. This will cause all sessions for older transactions in the same call (identified by CALLID) to shut down. IDFROM and IDTO represent the sides of the session, e.g. for the activation to succeed there had to be an B call for each of these sides. PARAM is an optional hash reference. If given it will be added as user information to the new session and given back in the information hash returned by L etc. The method returns two items: The first is information about the session like returned in L, the second is a flag, which is true, if the activation was for an already astablished session. The method is usually called whenever a SDP body is given and on ACK requests. =item close_session ( CALLID,CSEQ,IDFROM,IDTO ) This will cause the close of the session described by the arguments (which have the same meaning like in B). Usually called for BYE or CANCEL requests. For CANCEL it will be called with CSEQ (because it should cancel a specific transaction) while for BYE it will called with CSEQ undef, because it should end all sessions in this call. It will return a list with infos about all closed sessions. Each of these infos is a reference to a hash with the following items: =over 8 =item callid =item cseq =item idfrom =item idto =item bytes_from - number of bytes received on the 'from' side =item bytes_to - number of bytes received on the 'to' side =item from - space delimited list of "ip:port/range" for the media on the 'from' side =item to - same for the 'to' side =item created - C when the session was created =back Stateless proxies should forward the packet even if the session did not exist, because the packet might be a retransmit referring to an already closed session. =item expire ( [ %ARGS ] ) This causes the sessions and sockets to expire. It will return a list with a hash for each expired session. See L for details on the returned information. With %ARGS the behavior can be customized: =over 8 =item time Current time, can be given to save system call for getting current time. =item unused Expire time for unused sockets. Default ist 180, e.g. 3 minutes. =item active Expire time for active sessions. Default to 30 seconds. If no data gets transferred through the session for C seconds the session will be closed. =back =item callbacks This will return a list (not a reference) of C<< [cbid,fd,callback] >> pairs, where fd is the file descriptor of the socket and callback is a callback for B in L. cbid is a uniq id for each callback so that one get compare the result from different calls to L and see, what changed. Each of these callbacks should be invoked once the file descriptor gets readable and the callback will then forward the received packet to the other side of the session. =item sessions ( [ CALLBACK ] ) This will call CALLBACK on all sessions and return an array containing the results of the callbacks together. If no CALLBACK is given it will return all session objects. To use this function you might need to know the interna of the session objects (see source code), but in most cases it is enough to know, that session objects have a method L which will return infos about the session as hash like described in L. =item get_rtp_sockets ( NEW_ADDR, @MEDIA ) Allocates sockets for on address NEW_ADDR for @MEDIA. @MEDIA is in the format given by B in L. Returns reference to array of allocated media, each item in the array is C<< [ ADDR,BASE_PORT,\@SOCKS,\@TARGETS ] >>, where ADDR is NEW_ADDR, BASE_PORT the base port for the allocated sockets, @SOCKS the allocated sockets and @TARGETS the C of the original targets, e.g. where it needs to forward the data received on the sockets. If not all necssary sockets could be allocated it will allocate none and return C<()>. This method might be redefined to better control resource allocation or to cache temporally unused resources together with unget_rtp_sockets. =item unget_rtp_sockets ( NEW_MEDIA ) Will take resources back. NEW_MEDIA is the result from B. Returns nothing. Together with get_rtp_sockets it could be redefined to not destroy resources but to cache them for future use. =item dump This method is used for debugging only. It will return a string with information about all calls within this nathelper and all sessions and allocated sockets within the calls. =item number_of_calls Returns the number of calls within the nathelper. This vaalue has not much association with the result of B because there might be inactive sockets (not yet or no longer in active session) which don't affect the result of B. This value can be used to determine if B needs to be called at all. =back Net-SIP-0.822/lib/Net/SIP/NATHelper/Client.pm0000644000175100017510000000342013003624153016715 0ustar workworkuse strict; use warnings; ############################################################################ # # Net::SIP::NATHelper::Client # proxy for Net::SIP::NAT::Helper to communicate over sockets # with Net::SIP::NATHelper::Server # used in connection with bin/nathelper.pl # ############################################################################ package Net::SIP::NATHelper::Client; use Net::SIP::Debug; use Net::SIP::Util qw(invoke_callback INETSOCK); use IO::Socket; use Storable qw(nfreeze thaw); sub new { my ($class,$socket) = @_; my $create_socket = $socket =~m{/} ? [ \&__create_unix_socket, $socket ] : [ \&__create_tcp_socket, $socket ] ; my $self = bless { create_socket => $create_socket },$class; return $self; } sub allocate_sockets { my Net::SIP::NATHelper::Client $self = shift; return $self->rpc( 'allocate',@_ ); } sub activate_session { my Net::SIP::NATHelper::Client $self = shift; return $self->rpc( 'activate',@_ ); } sub close_session { my Net::SIP::NATHelper::Client $self = shift; return $self->rpc( 'close',@_ ); } sub rpc { my Net::SIP::NATHelper::Client $self = shift; my ($method,@arg) = @_; my $sock = invoke_callback( $self->{create_socket} ) || die $!; $sock->autoflush; my $packet = pack( "N/a*", nfreeze([$method,@arg])); print $sock $packet; read( $sock, my $len,4 ) || die $!; $len = unpack( "N",$len ); die if $len>32768; die $! unless $len == read( $sock, $packet, $len ); my $ref = eval { thaw($packet) } || die $@; return $$ref; } sub __create_unix_socket { my $socket = shift; return IO::Socket::UNIX->new( Type => SOCK_STREAM, Peer => $socket ); } sub __create_tcp_socket { my $socket = shift; return INETSOCK( $socket ); } 1; Net-SIP-0.822/lib/Net/SIP/Request.pod0000644000175100017510000000525613005561434015530 0ustar workwork =head1 NAME Net::SIP::Request - handling of SIP request packets =head1 SYNOPSIS my $req = Net::SIP::Request->new( 'INVITE',... ); my $ack = $req->create_ack(); =head1 DESCRIPTION Subclass of L for handling request packets. Has methods to create responses to requests and to authorize requests. =head1 EXAMPLES # create INVITE request my $invite = Net::SIP::Request->new( 'INVITE', 'sip:you@example.com', { from => ..., to => ... }, Net::SIP::SDP->new( ... ) ); # somehow send request and retrieve response $resp ... if ( $resp->code eq '401' or $resp->code eq '407' ) { # need to authorize request $invite->authorize( $resp, [ username, password ] ); # somehow send again and retrieve response $resp ... } if ( $resp->code ~m{^[2345]\d\d} ) { # got final response, send ACK my $ack = $invite->create_ack( $resp ); # somehow send $ack ... } =head1 CONSTRUCTOR Inherited from L. See there. =head1 METHODS =over 4 =item method Get method of request. =item uri Get URI part of request. =item set_uri ( STRING ) Set URI of request to STRING =item set_cseq ( NUMBER ) Set sequence number if C header to NUMBER. =item create_ack ( RESPONSE ) Returns Net::SIP::Request object for ACK request for the case when L RESPONSE was received in reply for packet C<$self>. =item create_cancel Returns Net::SIP::Request object to cancel request in C<$self>. =item create_response ( CODE, [MSG,] [ \%HEADER, BODY ] ) Returns Net::SIP::Response packet for the received request C<$self> with numerical code CODE and text message MSG. Header for the response will be based on the request, but can be added or overridden using \%HEADER. If MSG is not given (e.g. argument is missing, second argument is \%HEADER already) a builtin message for the code will be used. For details to \%HEADER and BODY see B in L. =item authorize ( RESPONSE, AUTH ) Tries to authorize request C<$self> based on the information in RESPONSE (a 401 or 407 "Authorization required" response) and AUTH. AUTH is either C<< [ user,pass ] >> if a global authorization info exists for all realms or C<< { realm1 => [ user1,pass1 ], realm2 => [ user2,pass2 ],... } >> if different credentials are provided for different realms or a callback C<< callback(realm)->[user,pass] >>. The realms, for which authorization is needed, are read from RESPONSE. The request C<$self> is modified in-place. If a modification occurred, e.g. if (parts of) the authorization requests could be resolved it will return TRUE, else FALSE. Supports only RFC2617 with md5 and empty qop or qop 'auth', not md5-sess or qop's like 'auth-int'. =back Net-SIP-0.822/lib/Net/SIP/Dropper/0000755000175100017510000000000013552315100014771 5ustar workworkNet-SIP-0.822/lib/Net/SIP/Dropper/ByField.pm0000644000175100017510000000464312271422677016673 0ustar workwork =head1 NAME Net::SIP::Dropper::ByField - drops SIP messages based on fields in SIP header =head1 SYNOPSIS my $drop_by_field = Net::SIP::Dropper::ByField->new( methods => [ 'REGISTER', '...', '' ], 'From' => qr/sip(?:vicious|sscuser)/, 'User-Agent' => qr/^friendly-scanner$/, ); my $dropper = Net::SIP::Dropper->new( cb => $drop_by_field ); my $chain = Net::SIP::ReceiveChain->new([ $dropper, ... ]); =head1 DESCRIPTION With C one can drop packets based on the contents of the fields in the SIP header. This can be used to drop specific user agents. =cut use strict; use warnings; package Net::SIP::Dropper::ByField; use Net::SIP::Util 'invoke_callback'; use Net::SIP::Debug; use fields qw(fields methods); =head1 CONSTRUCTOR =over 4 =item new ( ARGS ) ARGS is a hash with the following keys: =over 8 =item methods Optional argument to restrict dropping to specific methods. Is array reference of method names, if one of the names is empty also responses will be considered. If not given all packets will be checked. =item field-name Any argument other then C will be considered a field name. The value is a callback given to C, like for instance a Regexp. =back =back =cut sub new { my ($class,%fields) = @_; my $methods = delete $fields{methods}; # optional # initialize object my Net::SIP::Dropper::ByField $self = fields::new($class); $self->{methods} = $methods; $self->{fields} = [ map { ($_,$fields{$_}) } keys %fields ]; return $self } =head1 METHODS =over 4 =item run ( PACKET, LEG, FROM ) This method is called as a callback from the L object. It returns true if the packet should be dropped, e.g. if at least one of the in the constructor specified fields matches the specified value. =back =cut sub run { my Net::SIP::Dropper::ByField $self = shift; my ($packet,$leg,$from) = @_; # check if the packet type/method fits if (my $m = $self->{methods}) { if ($packet->is_response) { return if ! grep { !$_ } @$m } else { my $met = $packet->method; return if ! grep { $_ eq $met } @$m } }; my $f = $self->{fields}; for(my $i=0;$i<@$f;$i+=2) { my @v = $packet->get_header($f->[$i]) or next; if ( invoke_callback( $f->[$i+1],@v) ) { DEBUG(1,"message dropped because of header field <$f->[$i]> =~ ".$f->[$i+1]); return 1; } } return; } 1; Net-SIP-0.822/lib/Net/SIP/Dropper/ByIPPort.pm0000644000175100017510000001355113016115054017005 0ustar workwork =head1 NAME Net::SIP::Dropper::ByIPPort - drops SIP messages based on senders IP and port =head1 SYNOPSIS use Net::SIP::Dropper::ByIPPort; my $drop_by_ipport = Net::SIP::Dropper::ByIPPort->new( database => '/path/to/database.drop', methods => [ 'REGISTER', '...', '' ], attempts => 10, interval => 60, ); my $dropper = Net::SIP::Dropper->new( cb => $drop_by_ipport ); my $chain = Net::SIP::ReceiveChain->new([ $dropper, ... ]); =head1 DESCRIPTION With C one can drop packets, if too much packets are received from the same IP and port within a specific interval. This is to stop bad behaving clients. =cut use strict; use warnings; package Net::SIP::Dropper::ByIPPort; use Net::SIP::Debug; use Net::SIP::Util 'invoke_callback'; use fields qw(interval attempts methods dbcb data); =head1 CONSTRUCTOR =over 4 =item new ( ARGS ) ARGS is a hash with the following keys: =over 8 =item database Optional file name of database or callback for storing/retrieving the data. If it is a callback it will be called with C<< $callback->(\%data) >> to retrieve the data (C<%data> will be updated) and C<< $callback->(\%data,true) >> to save the data. No return value will be expected from the callback. %data contains the number of attempts from a specific IP, port at a specific time in the following format: C<< $data{ip}{port}{time} = count >> =item attempts After how many attempts within the specific interval the packet will be dropped. Argument is required. =item interval The interval for attempts. Argument is required. =item methods Optional argument to restrict dropping to specific methods. Is array reference of method names, if one of the names is empty also responses will be considered. If not given all packets will be checked. =back =back =cut sub new { my ($class,%args) = @_; my $interval = delete $args{interval} or croak('interval should be defined'); my $attempts = delete $args{attempts} or croak('attempts should be defined'); my $methods = delete $args{methods}; # optional my %ips_ports; my $dbcb; if ( my $db = delete $args{database} ) { if ( ! ref $db ) { # file name require Storable; if ( ! -e $db ) { # initialize DB Storable::store(\%ips_ports, $db) or croak("cannot create $db: $!"); } $dbcb = [ sub { my ($file,$data,$save) = @_; if ( $save ) { Storable::store($data,$file); } else { %$data = %{ Storable::retrieve($file) } } }, $db ]; } else { $dbcb = $db } # load contents of database invoke_callback($dbcb,\%ips_ports); DEBUG_DUMP(100, \%ips_ports); } # initialize object my Net::SIP::Dropper::ByIPPort $self = fields::new($class); $self->{data} = \%ips_ports; $self->{interval} = $interval; $self->{attempts} = $attempts; $self->{methods} = $methods; $self->{dbcb} = $dbcb; return $self } =head1 METHODS =over 4 =item run ( PACKET, LEG, FROM ) This method is called as a callback from the L object. It returns true if the packet should be dropped, e.g. if there are too much packets from the same ip,port within the given interval. =cut sub run { my Net::SIP::Dropper::ByIPPort $self = shift; my ($packet,$leg,$from) = @_; # expire current contents $self->expire; # check if the packet type/method fits if (my $m = $self->{methods}) { if ($packet->is_response) { return if ! grep { !$_ } @$m } else { my $met = $packet->method; return if ! grep { $_ eq $met } @$m } }; # enter ip,port into db my ($ip,$port) = ($from->{addr},$from->{port}); $self->{data}{$ip}{$port}{ time() }++; $self->savedb(); # count attempts in interval # because everything outside of interval is expired we can # just look at all entries for ip,port my $count = 0; for (values %{$self->{data}{$ip}{$port}} ) { $count += $_; } # by using port = 0 one can block the whole IP for (values %{$self->{data}{$ip}{0} || {}} ) { $count += $_; } # drop if too much attempts if ( $count >= $self->{attempts} ) { DEBUG(1,"message dropped because $ip:$port was in database with $count attempts"); return 1; } return; } =item expire This method is called from within C but can also be called by hand. It will expire all entries which are outside of the interval. =cut sub expire { my Net::SIP::Dropper::ByIPPort $self = shift; my $interval = $self->{interval}; my $data = $self->{data}; my $maxtime = time() - $interval; my $changed; for my $ip ( keys %$data ) { my $ipp = $data->{$ip}; for my $port (keys %$ipp) { my $ippt = $ipp->{$port}; for my $time (keys %$ippt) { if ($time<=$maxtime) { delete $ippt->{$time}; $changed = 1; } } delete $ipp->{$port} if ! %$ippt; } delete $data->{$ip} if ! %$ipp; } $self->savedb if $changed; } =item savedb This method is called from C and C for saving to the database after changes, but can be called by hand to, useful if you made manual changes using the C method. =cut sub savedb { my Net::SIP::Dropper::ByIPPort $self = shift; my $dbcb = $self->{dbcb} or return; invoke_callback($dbcb,$self->{data},'save') } =item data This method gives access to the internal hash which stores the attempts. An attempt from a specific IP and port and a specific time (as int, like time() gives) will be added to C<< $self->data->{ip}{port}{time} >>. By manually manipulating the hash one can restrict a specific IP,port forever (just set time to a large value and add a high number of attempts) or even restrict access for the whole IP (all ports) until time by using a port number of 0. After changes to the data it is advised to call C. =cut sub data { my Net::SIP::Dropper::ByIPPort $self = shift; return $self->{data} } =pod =back =cut 1; Net-SIP-0.822/lib/Net/SIP/Packet.pm0000644000175100017510000007043313431274020015133 0ustar workwork########################################################################### # Net::SIP::Packet # parsing, creating and manipulating of SIP packets ########################################################################### use strict; use warnings; package Net::SIP::Packet; use Net::SIP::Debug; use Storable; use Net::SIP::SDP; use Carp 'croak'; use fields qw( code method text header lines body as_string ); # code: numeric response code in responses # method request method in requests # text: response text or request URI # body: scalar with body # as_string: string representation # lines: array-ref or [ original_header_lines, number_of_parts ] # header: array-ref of Net::SIP::HeaderPair ########################################################################### # Constructor - Creates new object. # If there are more than one argument it will forward to new_from_parts. # If the only argument is a scalar it will forward to new_from_string. # Otherwise it will just create the object of the given class and if # there is an argument treat is as a hash to fill the new object. # # Apart from new there are also _new_request and _new_response. # These can be overridden so that application specific classes for # request and response will be used for the new object. # # Args: see new_from_parts(..)|new_from_string($scalar)|\%hash|none # Returns: $self ########################################################################### sub new { my $class = shift; return $class->new_from_parts(@_) if @_>1; return $class->new_from_string(@_) if @_ && !ref($_[0]); my $self = fields::new($class); %$self = %{$_[0]} if @_; return $self; } sub _new_request { shift; return Net::SIP::Request->new(@_); } sub _new_response { shift; return Net::SIP::Response->new(@_); } ########################################################################### # create new object from parts # Args: ($class,$code_or_method,$text,$header,$body) # $code_or_method: Response code or request method # $text: Response text or request URI # $header: Header representation as array or hash # either [ [key1 => val2],[key2 => val2],... ] where the same # key can occure multiple times # or { key1 => val1, key2 => val2 } where val can be either # a scalar or an array-ref (if the same key has multiple values) # $body: Body as string # Returns: $self # Comment: # the actual object will be created with _new_request and _new_response and # thus will usually be a subclass of Net::SIP::Packet ########################################################################### sub new_from_parts { my ($class,$code,$text,$header,$body) = @_; # header can be hash-ref or array-ref # if hash-ref convert it to array-ref sorted by key # (sort just to make the result predictable) if ( UNIVERSAL::isa( $header,'HASH' )) { my @hnew; foreach my $key ( sort keys %$header ) { my $v = $header->{$key}; foreach my $value ( ref($v) ? @$v : ($v) ) { push @hnew,[ $key,$value ]; } } $header = \@hnew; } my $self = $code =~m{^\d} ? $class->_new_response({ code => $code }) : $class->_new_request({ method => uc($code) }); $self->{text} = defined($text) ? $text:''; # $self->{header} is list of Net::SIP::HeaderPair which cares about normalized # keys while maintaining the original key, so that one can restore header # the elements from @$header can be either [ key,value ] or Net::SIP::HeaderPair's # but have to be all from the same type my @hnew; my $normalized = 0; for( my $i=0;$i<@$header;$i++ ) { my $h = $header->[$i]; if ( UNIVERSAL::isa($h,'Net::SIP::HeaderPair')) { # already normalized $normalized = 1; push @hnew,$h; } else { my ($key,$value) = @$h; defined($value) || next; croak( "mix between normalized and not normalized data in header" ) if $normalized; push @hnew, Net::SIP::HeaderPair->new( $key,$value ) ; } } $self->{header} = \@hnew; # as_string is still undef, it will be evaluated once we call as_string() if ( ref($body)) { if ( !$self->get_header( 'content-type' )) { my $sub = UNIVERSAL::can( $body, 'content_type' ); $self->set_header( 'content-type' => $sub->($body) ) if $sub; } $body = $body->as_string; } $self->{body} = $body; return $self; } ########################################################################### # Create new packet from string # Args: ($class,$string) # $string: String representation of packet # Returns: $self # Comment: # for the class of $self see comment in new_from_parts above ########################################################################### sub new_from_string { my ($class,$string) = @_; my $data = _string2parts($string); return $data->{method} ? $class->_new_request($data) : $class->_new_response($data); } ########################################################################### # Find out if it is a request # Args: $self # Returns: true if it's a request ########################################################################### sub is_request { my $self = shift; $self->{header} || $self->as_parts(); return $self->{method} && 1; } ########################################################################### # Find out if it is a response # Args: $self # Returns: true if it's a response ########################################################################### sub is_response { my $self = shift; $self->{header} || $self->as_parts(); return ! $self->{method}; } ########################################################################### # Return transaction Id of packet, consisting of the call-id and # the CSeq num. Method is not included because ACK or CANCEL requests # belong to the same transaction as the INVITE # Responses have the same TID as the request # Args: $self # Returns: $tid ########################################################################### sub tid { my Net::SIP::Packet $self = shift; $self->get_header( 'cseq' ) =~m{^(\d+)}; return $self->get_header( 'call-id' ).' '.$1; } ########################################################################### # Accessors for Headerelements ########################################################################### ########################################################################### # Access cseq Header # Args: $self # Returns: $cseq_value ########################################################################### sub cseq { scalar( shift->get_header('cseq')) } ########################################################################### # Access call-id Header # Args: $self # Returns: $callid ########################################################################### sub callid { scalar( shift->get_header('call-id')) } ########################################################################### # Access header # Args: ($self; $key) # $key: (optional) which headerkey to access # Returns: @val|\%header # @val: if key given returns all values for this key # croak()s if in scalar context and I've more then one value for the key # \%header: if no key given returns hash with # { key1 => \@val1, key2 => \@val2,.. } ########################################################################### sub get_header { my ($self,$key) = @_; my $hdr = ($self->as_parts)[2]; if ( $key ) { $key = _normalize_hdrkey($key); my @v; foreach my $h (@$hdr) { push @v,$h->{value} if $h->{key} eq $key; } return @v if wantarray; if (@v>1) { # looks like we have multiple headers but expect only # one. Because we've seen bad client which issue multiple # content-length header we try if all in @v are the same my %v = map { $_ => 1 } @v; return $v[0] if keys(%v) == 1; # ok, only one croak( "multiple values for $key in packet:\n".$self->as_string ); } return $v[0]; } else { my %result; foreach my $h (@$hdr) { push @{ $result{$h->{key}} }, $h->{value}; } return \%result; } } ########################################################################### # get header as Net::SIP::HeaderVal # like get_header, but instead of giving scalar values gives Net::SIP::HeaderVal # objects which have various accessors, like extracting the parameters # Args: ($self; $key) # $key: (optional) which headerkey to access # Returns: @val|\%header # @val: if key given returns all values (Net::SIP::HeaderVal) for this key # croak()s if in scalar context and I've more then one value for the key # \%header: if no key given returns hash with # { key1 => \@val1, key2 => \@val2,.. } where val are Net::SIP::HeaderVal ########################################################################### sub get_header_hashval { my ($self,$key) = @_; my $hdr = ($self->as_parts)[2]; if ( $key ) { $key = _normalize_hdrkey($key); my @v; foreach my $h (@$hdr) { push @v,Net::SIP::HeaderVal->new( $h ) if $h->{key} eq $key; } return @v if wantarray; croak( "multiple values for $key" ) if @v>1; return $v[0]; } else { my %result; foreach my $h (@$hdr) { push @{ $result{$h->{key}} }, Net::SIP::HeaderVal->new( $h ); } return \%result; } } ########################################################################### # Add header to SIP packet, headers gets added after all other headers # Args: ($self,$key,$val) # $key: Header key # $val: scalar or \@array which contains value(s) ########################################################################### sub add_header { my ($self,$key,$val) = @_; my $hdr = ($self->as_parts)[2]; foreach my $v ( ref($val) ? @$val:$val ) { ### TODO: should add quoting to $v if necessary push @$hdr, Net::SIP::HeaderPair->new( $key,$v ); } $self->_update_string(); } ########################################################################### # Add header to SIP packet, header gets added before all other headers # Args: ($self,$key,$val) # $key: Header key # $val: scalar or \@array which contains value(s) ########################################################################### sub insert_header { my ($self,$key,$val) = @_; my $hdr = ($self->as_parts)[2]; foreach my $v ( ref($val) ? @$val:$val ) { ### TODO: should add quoting to $v if necessary unshift @$hdr, Net::SIP::HeaderPair->new( $key,$v ); } $self->_update_string(); } ########################################################################### # Delete all headers for a key # Args: ($self,$key) ########################################################################### sub del_header { my ($self,$key) = @_; $key = _normalize_hdrkey($key); my $hdr = ($self->as_parts)[2]; @$hdr = grep { $_->{key} ne $key } @$hdr; $self->_update_string(); } ########################################################################### # Set header for key to val, e.g. delete all remaining headers for key # Args: ($self,$key,$val) # $key: Header key # $val: scalar or \@array which contains value(s) ########################################################################### sub set_header { my ($self,$key,$val) = @_; $key = _normalize_hdrkey($key); # del_header my $hdr = ($self->as_parts)[2]; @$hdr = grep { $_->{key} ne $key } @$hdr; # add_header foreach my $v ( ref($val) ? @$val:$val ) { ### TODO: should add quoting to $v if necessary push @$hdr, Net::SIP::HeaderPair->new( $key,$v ); } $self->_update_string(); } ########################################################################### # set the body # Args: ($self,$body) # $body: string or object with method as_string (like Net::SIP::SDP) # Returns: NONE ########################################################################### sub set_body { my ($self,$body) = @_; if ( ref($body)) { if ( !$self->get_header( 'content-type' )) { my $sub = UNIVERSAL::can( $body, 'content_type' ); $self->set_header( 'content-type' => $sub->($body) ) if $sub; } $body = $body->as_string; } $self->as_parts; $self->{body} = $body; $self->_update_string(); } ########################################################################### # Iterate over all headers with sup and remove or manipulate them # Args: ($self,@arg) # @arg: either $key => $sub or only $sub # if $key is given only headers for this key gets modified # $sub is either \&code or [ \&code, @args ] # code gets $pair (Net::SIP::HeaderPair) as last parameter # to remove header it should call $pair->remove, if it modify # header it should call $pair->set_modified ########################################################################### sub scan_header { my Net::SIP::Packet $self = shift; my $key = @_>1 ? _normalize_hdrkey(shift) : undef; my $sub = shift; ($sub, my @args) = ref($sub) eq 'CODE' ? ($sub):@$sub; my $hdr = ($self->as_parts)[2]; foreach my $h (@$hdr) { next if $key && $h->{key} ne $key; # in-place modify or delete (set key to undef) $sub->(@args,$h); } # remove deleted entries ( !key ) from @$hdr @$hdr = grep { $_->{key} } @$hdr; $self->_update_string(); } ########################################################################### # Return packet as string # tries to restore as much as possible from original packet (if created # from string) # Args: $self # Returns: $packet_as_string ########################################################################### sub as_string { my $self = shift; # check if content-length header is up-to-date my $body = $self->{body} || ''; my $cl = $self->get_header( 'content-length' ); if ( defined($cl) && $cl != length($body) ) { $self->set_header( 'content-length',length($body)) } # return immediately if request is up to date return $self->{as_string} if $self->{as_string}; my $header = $self->{header}; # check if the lines from the original packet (if created # from string, see as_parts) are up-to-date my @result; if ( my $lines = $self->{lines} ) { for (my $i=0;$i<@$lines;$i++ ) { my ($line,$count) = @{ $lines->[$i] || next }; # check if $count entries for line-index $i in headers my @hi = grep { my $line = $header->[$_]{line}; ( defined($line) && $line == $i ) ? 1:0; } (0..$#$header); if ( @hi == $count ) { # assume that line wasn't changed because the count is right $result[ $hi[0] ] = $line; } elsif ( @hi ) { # some parts from this line have been modified # place remaining parts back to same line my $v = join( ", ", map { $header->[$_]{value} } @hi ); $v =~s{\r?\n\s*}{\r\n }g; # \r?\n\s* -> \r\n + space for continuation lines my $r = $result[ $hi[0] ] = $header->[ $hi[0] ]{orig_key}.": ".$v; $lines->[$i] = [ $r,int(@hi) ]; # and update $lines } else { # nothing remaining from line $i, update lines delete $lines->[$i]; } } } # all lines from $header which had a defined line index should have been # handled by the code above, now care about the lines w/o defined line foreach my $hi ( grep { !defined( $header->[$_]{line} ) } (0..$#$header) ) { my $v = $header->[$hi]{value}; $v =~s{\r?\n\s*}{\r\n }g; # \r?\n\s* -> \r\n + space for continuation lines $result[$hi] = ucfirst($header->[$hi]{key}).": ".$v; } # (re)build packet my $hdr_string = $self->{method} ? "$self->{method} $self->{text} SIP/2.0\r\n" # Request : "SIP/2.0 $self->{code} $self->{text}\r\n"; # Response $hdr_string .= join( "\r\n", grep { $_ } @result )."\r\n"; # add content-length header if there was none $hdr_string .= sprintf( "Content-length: %d\r\n", length( $body )) if !defined($cl); return ( $self->{as_string} = $hdr_string."\r\n".$body ); } ########################################################################### # packet dump in long or short form, used mainly for debuging # Args: ($self,?$level) # $level: level of details: undef|0 -> one line, else -> as_string # Returns: $dump_as_string ########################################################################### sub dump { my Net::SIP::Packet $self = shift; my $level = shift; if ( !$level ) { if ( $self->is_request ) { my ($method,$text,$header,$body) = $self->as_parts; return "REQ $method $text ".( $body ? 'with body' :'' ); } else { my ($code,$text,$header,$body) = $self->as_parts; return "RESP $code '$text' ".( $body ? 'with body' :'' ); } } else { return $self->as_string } } ########################################################################### # Return parts # Args: ($self) # Returns: ($code_or_method,$text,$header,$body) # $code_or_method: Response code or request method # $text: Response text or request URI # $header: Header representation as array # [ [key1 => val2],[key2 => val2],... ] where the same # key can occure multiple times # $body: Body as string # Comment: # Output from this method is directly usable as input to new_from_parts ########################################################################### sub as_parts { my $self = shift; # if parts are up to date return immediately if ( ! $self->{header} ) { my $data = _string2parts( $self->{as_string} ); %$self = ( %$self,%$data ); } return @{$self}{qw(method text header body)} if $self->{method}; return @{$self}{qw(code text header body)}; } { my $word_rx = qr{[\w\-\.!%\*+`'~()<>:"/?{}\x1c\x1b\x1d]+}; my $callid_rx = qr{^$word_rx(?:\@$word_rx)?$}; my %key2parser = ( # FIXME: More of these should be more strict to filter out invalid values # for now they are only given here to distinguish them from the keys, which # can be given multiple times either on different lines or on the same delimited # by comma 'www-authenticate' => \&_hdrkey_parse_keep, 'authorization' => \&_hdrkey_parse_keep, 'proxy-authenticate' => \&_hdrkey_parse_keep, 'proxy-authorization' => \&_hdrkey_parse_keep, 'date' => \&_hdrkey_parse_keep, 'content-disposition' => \&_hdrkey_parse_keep, 'content-type' => \&_hdrkey_parse_keep, 'mime-version' => \&_hdrkey_parse_keep, 'organization' => \&_hdrkey_parse_keep, 'priority' => \&_hdrkey_parse_keep, 'reply-to' => \&_hdrkey_parse_keep, 'retry-after' => \&_hdrkey_parse_keep, 'server' => \&_hdrkey_parse_keep, 'to' => \&_hdrkey_parse_keep, 'user-agent' => \&_hdrkey_parse_keep, 'content-length' => \&_hdrkey_parse_num, 'expires' => \&_hdrkey_parse_num, 'max-forwards' => \&_hdrkey_parse_num, 'min-expires' => \&_hdrkey_parse_num, 'via' => \&_hdrkey_parse_comma_seperated, 'contact' => \&_hdrkey_parse_comma_seperated, 'record-route' => \&_hdrkey_parse_comma_seperated, 'route' => \&_hdrkey_parse_comma_seperated, 'allow' => \&_hdrkey_parse_comma_seperated, 'supported' => \&_hdrkey_parse_comma_seperated, 'unsupported' => \&_hdrkey_parse_comma_seperated, 'in-reply-to' => \&_hdrkey_parse_comma_seperated, 'accept' => \&_hdrkey_parse_comma_seperated, 'accept-encoding' => \&_hdrkey_parse_comma_seperated, 'accept-language' => \&_hdrkey_parse_comma_seperated, 'proxy-require' => \&_hdrkey_parse_comma_seperated, 'require' => \&_hdrkey_parse_comma_seperated, 'content-encoding' => \&_hdrkey_parse_comma_seperated, 'content-language' => \&_hdrkey_parse_comma_seperated, 'alert-info' => \&_hdrkey_parse_comma_seperated, 'call-info' => \&_hdrkey_parse_comma_seperated, 'error-info' => \&_hdrkey_parse_comma_seperated, 'error-info' => \&_hdrkey_parse_comma_seperated, 'warning' => \&_hdrkey_parse_comma_seperated, 'call-id' => sub { $_[0] =~ $callid_rx or die "invalid callid, should be 'word [@ word]'\n"; return $_[0]; }, 'cseq' => sub { $_[0] =~ m{^\d+\s+\w+\s*$} or die "invalid cseq, should be 'number method'\n"; return $_[0]; }, ); my %once = map { ($_ => 1) } qw(cseq content-type from to call-id content-length); my %key2check = ( rsp => undef, req => { cseq => sub { my ($v,$result) = @_; $v =~ m{^\d+\s+(\w+)\s*$} or die "invalid cseq, should be 'number method'\n"; $result->{method} eq $1 or die "method in cseq does not match method of request\n"; }, } ); sub _hdrkey_parse_keep { return $_[0] }; sub _hdrkey_parse_num { my ($v,$k) = @_; $v =~m{^(\d+)\s*$} || die "invalid $k, should be number\n"; return $1; }; sub _hdrkey_parse_comma_seperated { my ($v,$k) = @_; my @v = ( '' ); my $quote = ''; # split on komma (but not if quoted) while (1) { if ( $quote ) { if ( $v =~m{\G(.*?)(\\|$quote)}gc ) { if ( $2 eq "\\" ) { $v[-1].=$1.$2.substr( $v,pos($v),1 ); pos($v)++; } else { $v[-1].=$1.$2; $quote = ''; } } else { # missing end-quote die "missing '$quote' in '$v'\n"; } } elsif ( $v =~m{\G(.*?)([\\"<,])}gc ) { if ( $2 eq "\\" ) { $v[-1].=$1.$2.substr( $v,pos($v),1 ); pos($v)++; } elsif ( $2 eq ',' ) { # next item if not quoted ( $v[-1].=$1 ) =~s{\s+$}{}; # strip trailing space push @v,'' if !$quote; $v =~m{\G\s+}gc; # skip space after ',' } else { $v[-1].=$1.$2; $quote = $2 eq '<' ? '>':$2; } } else { # add rest to last from @v $v[-1].= substr($v,pos($v)||0 ); last; } } return @v; } sub _string2parts { my $string = shift; my %result = ( as_string => $string ); # otherwise parse request my ($header,$body) = split( m{\r?\n\r?\n}, $string,2 ); my @header = split( m{\r?\n}, $header ); my $key2check; if ( $header[0] =~m{^SIP/2.0\s+(\d+)\s+(\S.*?)\s*$} ) { # Response, e.g. SIP/2.0 407 Authorization required $result{code} = $1; $result{text} = $2; $key2check = $key2check{rsp}; } elsif ( $header[0] =~m{^(\w+)\s+(\S.*?)\s+SIP/2\.0\s*$} ) { # Request, e.g. INVITE SIP/2.0 $result{method} = $1; $result{text} = $2; $key2check = $key2check{req}; } else { die "bad request: starts with '$header[0]'\n"; } shift(@header); $result{body} = $body; my @hdr; my @lines; my @check; my %check_once; while (@header) { my ($k,$v) = $header[0] =~m{^([^\s:]+)\s*:\s*(.*)} or die "bad header line $header[0]\n"; my $line = shift(@header); while ( @header && $header[0] =~m{^\s+(.*)} ) { # continuation line $v .= "\n$1"; $line .= shift(@header); } my $nk = _normalize_hdrkey($k); my $parse = $key2parser{$nk}; my @v = $parse ? $parse->($v,$nk) : _hdrkey_parse_keep($v,$nk); if ( @v>1 ) { for( my $i=0;$i<@v;$i++ ) { push @hdr, Net::SIP::HeaderPair->new( $k,$v[$i],scalar(@lines),$i ); } } else { push @hdr, Net::SIP::HeaderPair->new( $k,$v[0],scalar(@lines) ); } if (my $k2c = $key2check->{$nk}) { push @check, [ $k2c, $_ ] for @v; } if ($once{$nk}) { ($check_once{$nk} //= $_) eq $_ or die "conflicting definition of $nk\n" for @v; } push @lines, [ $line, int(@v) ]; } $result{header} = \@hdr; $result{lines} = \@lines; for(@check) { my ($sub,$v) = @$_; $sub->($v,\%result); } return \%result; } } ########################################################################### # return SDP body # Args: $self # Returns: $body # $body: Net::SIP::SDP object if body exists and content-type is # application/sdp (or not defined) ########################################################################### sub sdp_body { my Net::SIP::Packet $self = shift; my $ct = $self->get_header( 'content-type' ); return if $ct && lc($ct) ne 'application/sdp'; my $body = ($self->as_parts)[3] || return; return Net::SIP::SDP->new( $body ); } ########################################################################### # clone packet, so that modification does not affect the original # Args: $self # Returns: $clone ########################################################################### sub clone { return Storable::dclone( shift ); } ########################################################################### # Trigger updating parts, e.g. code, method, header... # done by setting header as undef if as_string is set, so the next time # I'll try to access code it will be recalculated from string # Args: $self ########################################################################### sub _update_parts { my $self = shift; $self->{header} = undef if $self->{as_string}; } ########################################################################### # Trigger updating string # done by setting as_string as undef if header is set, so the next time # I'll try to access as_string it will be recalculated from the parts # Args: $self ########################################################################### sub _update_string { my $self = shift; $self->{as_string} = undef if $self->{header}; } ########################################################################### # access _normalize_hdrkey function from Net::SIP::HeaderPair # Args: $key # Returns: $key_normalized ########################################################################### sub _normalize_hdrkey { goto &Net::SIP::HeaderPair::_normalize_hdrkey } ########################################################################### # Net::SIP::HeaderPair # container for normalized key,value and some infos to restore # string representation ########################################################################### package Net::SIP::HeaderPair; use fields qw( key value orig_key line pos ); # key: normalized key: lower case, not compact # value: value # orig_key: original key: can be mixed case and compact # line: index of header line within original request # pos: relativ position in line (starting with 0) if multiple # values are given in one line ########################################################################### # Create new HeaderPair # Args: ($class,$key,$value,$line,$pos) # $key: original key # $value: value # $line: index of header line in original header # $pos: index within header line if multiple values are in line # Returns: $self ########################################################################### sub new { my ($class,$key,$value,$line,$pos) = @_; my $self = fields::new( $class ); $self->{key} = _normalize_hdrkey( $key); $self->{value} = $value; $self->{orig_key} = $key; $self->{line} = $line; $self->{pos} = $pos; return $self; } ########################################################################### # Mark HeaderPair as removed by setting key to undef # used from Net::SIP:Packet::scan_header # Args: $self ########################################################################### sub remove { # mark es removed shift->{key} = undef } ########################################################################### # Mark HeaderPair as modified by setting line to undef and thus deassociating # it from the original header line # Args: $self ########################################################################### sub set_modified { # mark as modified my $self = shift; $self->{line} = $self->{pos} = undef; } { my %alias = ( i => 'call-id', m => 'contact', e => 'content-encoding', l => 'content-length', c => 'content-type', f => 'from', s => 'subject', k => 'supported', t => 'to', v => 'via', ); sub _normalize_hdrkey { my $key = lc(shift); return $alias{$key} || $key; } } ########################################################################### # Net::SIP::HeaderVal; # gives string representation and hash representation # (split by ';' or ',') of header value ########################################################################### package Net::SIP::HeaderVal; use Net::SIP::Util qw(sip_hdrval2parts); use fields qw( data parameter ); # WWW-Authenticate: Digest method="md5",qop="auth",... # To: Bob Example ;tag=2626262;... # # data: the part before the first argument, e.g. "Digest" or # "Bob Example " # parameter: hash of parameters, e.g { method => md5, qop => auth } # or { tag => 2626262, ... } ########################################################################### # create new object from string # knows which headers have ',' as delimiter and the rest uses ';' # Args: ($class,$pair) # $pair: Net::SIP::HeaderPair # Returns: $self ########################################################################### sub new { my $class = shift; my Net::SIP::HeaderPair $pair = shift; my $key = $pair->{key}; my $v = $pair->{value}; my $self = fields::new($class); ($self->{data}, $self->{parameter}) = sip_hdrval2parts( $key,$v ); return $self; } 1; Net-SIP-0.822/lib/Net/SIP/Authorize.pm0000644000175100017510000002376512271422677015722 0ustar workwork########################################################################### # package Net::SIP::Authorize # use in ReceiveChain in front of StatelessProxy, Endpoint.. to authorize request # by enforcing authorization and only handling request only if it was # fully authorized ########################################################################### use strict; use warnings; package Net::SIP::Authorize; use Carp 'croak'; use Net::SIP::Debug; use Net::SIP::Util ':all'; use Digest::MD5 'md5_hex'; use fields qw( realm opaque user2pass user2a1 i_am_proxy dispatcher filter ); ########################################################################### # creates new Authorize object # Args: ($class,%args) # %args # realm: which realm to announce # user2pass: hash of (username => password) or callback which returns # password if given username # dispatcher: Dispatcher object # i_am_proxy: true if should send Proxy-Authenticate, not WWW-Authenticate # filter: hashref with extra verification chain, see packages below. # Usage: # filter => { # # filter chain for registration # REGISTER => [ # # all of this three must succeed (user can regist himself) # [ 'ToIsFrom','FromIsRealm','FromIsAuthUser' ], # # or this must succeed # \&call_back, # callback. If arrayref you MUST set [ \&call_back ] # ] # # filter chain for invites # INVITE => 'FromIsRealm', # } # Returns: $self ########################################################################### sub new { my ($class,%args) = @_; my $self = fields::new( $class ); $self->{realm} = $args{realm} || 'p5-net-sip'; $self->{opaque} = $args{opaque}; $args{user2pass} || $args{user2a1} || croak 'no user2pass or user2a1 known'; $self->{user2pass} = $args{user2pass}; $self->{user2a1} = $args{user2a1}; $self->{i_am_proxy} = $args{i_am_proxy}; $self->{dispatcher} = $args{dispatcher} || croak 'no dispatcher'; if ( my $f = $args{filter}) { croak 'filter must be hashref' if ref($f) ne 'HASH'; my %filter; while (my($method,$chain) = each %$f) { $chain = [ $chain ] if ref($chain) ne 'ARRAY'; map { $_ = [$_] if ref($_) ne 'ARRAY' } @$chain; # now we have: # method => [[ cb00,cb01,cb02,..],[ cb10,cb11,cb12,..],...] # where either the cb0* chain or the cb1* chain or the cbX* has to succeed for my $or (@$chain) { for (@$or) { if (ref($_)) { # assume callback } else { # must have authorize class with verify method my $pkg = __PACKAGE__."::$_"; my $sub = UNIVERSAL::can($pkg,'verify') || do { # load package eval "require $pkg"; UNIVERSAL::can($pkg,'verify') } or die "cannot find sub ${pkg}::verify"; $_ = $sub; } } } $filter{uc($method)} = $chain; } $self->{filter} = \%filter; } return $self; } ########################################################################### # handle packet, called from Net::SIP::Dispatcher on incoming requests # Args: ($self,$packet,$leg,$addr) # $packet: Net::SIP::Request # $leg: Net::SIP::Leg where request came in (and response gets send out) # $addr: ip:port where request came from and response will be send # Returns: TRUE if it handled the packet ########################################################################### sub receive { my Net::SIP::Authorize $self = shift; my ($packet,$leg,$addr) = @_; # don't handle responses if ( $packet->is_response ) { DEBUG( 100,"pass thru response" ); return; } my $method = $packet->method; # check authorization on request my ($rq_key,$rs_key,$acode) = $self->{i_am_proxy} ? ( 'proxy-authorization', 'proxy-authenticate',407 ) : ( 'authorization','www-authenticate',401 ) ; my @auth = $packet->get_header( $rq_key ); my $user2pass = $self->{user2pass}; my $user2a1 = $self->{user2a1}; my $realm = $self->{realm}; my $opaque = $self->{opaque}; # there might be multiple auth, pick the right realm my (@keep_auth,$authorized); foreach my $auth ( @auth ) { # RFC 2617 my ($data,$param) = sip_hdrval2parts( $rq_key => $auth ); if ( $param->{realm} ne $realm ) { # not for me push @keep_auth,$auth; next; } if ( defined $opaque ) { if ( ! defined $param->{opaque} ) { DEBUG( 10,"expected opaque value, but got nothing" ); next; } elsif ( $param->{opaque} ne $opaque ) { DEBUG( 10,"got wrong opaque value '$param->{opaque}', expected '$opaque'" ); next; } } my ($user,$nonce,$uri,$resp,$qop,$cnonce,$algo ) = @{$param}{ qw/ username nonce uri response qop cnonce algorithm / }; if ( lc($data) ne 'digest' || ( $algo && lc($algo) ne 'md5' ) || ( $qop && $qop ne 'auth' ) ) { DEBUG( 10,"unsupported response: $auth" ); next; }; # we support with and w/o qop # get a1_hex from either user2a1 or user2pass my $a1_hex; if ( ref($user2a1)) { if ( ref($user2a1) eq 'HASH' ) { $a1_hex = $user2a1->{$user} } else { $a1_hex = invoke_callback( $user2a1,$user,$realm ); } } if ( ! defined($a1_hex) && ref($user2pass)) { my $pass; if ( ref($user2pass) eq 'HASH' ) { $pass = $user2pass->{$user} } else { $pass = invoke_callback( $user2pass,$user ); } # if wrong credentials ask again for authorization last if ! defined $pass; $a1_hex = md5_hex(join( ':',$user,$realm,$pass )); } last if ! defined $a1_hex; # not in user2a1 || user2pass # ACK just reuse the authorization from INVITE, so they should # be checked against method INVITE # for CANCEL the RFC doesn't say anything, so we assume it uses # CANCEL but try INVITE if this fails my @a2 = $method eq 'ACK' ? ("INVITE:$uri") : $method eq 'CANCEL' ? ("CANCEL:$uri","INVITE:$uri") : ("$method:$uri"); while (my $a2 = shift(@a2)) { my $want_response; if ( $qop ) { # 3.2.2.1 $want_response = md5_hex( join( ':', $a1_hex, $nonce, 1, $cnonce, $qop, md5_hex($a2) )); } else { # 3.2.2.1 compability with RFC2069 $want_response = md5_hex( join( ':', $a1_hex, $nonce, md5_hex($a2) )); } if ( $resp eq $want_response ) { if ($self->{filter} and my $or = $self->{filter}{$method}) { for my $and (@$or) { $authorized = 1; for my $cb (@$and) { if ( ! invoke_callback( $cb,$packet,$leg,$addr,$user,$realm)) { $authorized = 0; last; } } last if $authorized; } } else { $authorized = 1; } last; } } } # if authorized remove authorization data from this realm # and pass packet thru if ( $authorized ) { DEBUG( 10, "Request authorized ". $packet->dump ); # set header again $packet->set_header( $rq_key => \@keep_auth ); return; } # CANCEL or ACK cannot be prompted for authorization, so # they should provide the right data already # unauthorized CANCEL or ACK are only valid as response to # 401/407 from this Authorize, so they should not be propagated if ($method eq 'ACK') { # cancel delivery of response to INVITE $self->{dispatcher}->cancel_delivery( $packet->tid ); return $acode; } elsif ($method eq 'CANCEL') { return $acode; } # not authorized yet, ask to authenticate # keep it simple RFC2069 style my $digest = qq[Digest algorithm=MD5, realm="$realm",]. ( defined($opaque) ? qq[ opaque="$opaque",] : '' ). ' nonce="'. md5_hex( $realm.rand(2**32)).'"'; my $resp = $packet->create_response( $acode, 'Authorization required', { $rs_key => $digest } ); $self->{dispatcher}->deliver( $resp, leg => $leg, dst_addr => $addr ); # return $acode (TRUE) to show that packet should # not passed thru return $acode; } ########################################################################### # additional verifications # Net::SIP::Authorize::FromIsRealm - checks if the domain in 'From' is # the same as the realm in 'Authorization' # Net::SIP::Authorize::FromIsAuthUser - checks if the user in 'From' is # the same as the username in 'Authorization' # Net::SIP::Authorize::ToIsFrom - checks if 'To' and 'From' are equal # # Args each: ($packet,$leg,$addr,$auth_user,$auth_realm) # $packet: Net::SIP::Request # $leg: Net::SIP::Leg where request came in (and response gets send out) # $addr: ip:port where request came from and response will be send # $auth_user: username from 'Authorization' # $auth_realm: realm from 'Authorization' # Returns: TRUE (1) | FALSE (0) ########################################################################### package Net::SIP::Authorize::FromIsRealm; use Net::SIP::Util qw( sip_hdrval2parts sip_uri2parts ); use Net::SIP::Debug; sub verify { my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_; my $from = $packet->get_header('from'); ($from) = sip_hdrval2parts( from => $from ); my ($domain) = sip_uri2parts($from); $domain =~s{:\w+$}{}; return 1 if lc($domain) eq lc($auth_realm); # exact domain return 1 if $domain =~m{\.\Q$auth_realm\E$}i; # subdomain DEBUG( 10, "No Auth-success: From-domain is '$domain' and realm is '$auth_realm'" ); return 0; } package Net::SIP::Authorize::FromIsAuthUser; use Net::SIP::Util qw( sip_hdrval2parts sip_uri2parts ); use Net::SIP::Debug; sub verify { my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_; my $from = $packet->get_header('from'); ($from) = sip_hdrval2parts( from => $from ); my (undef,$user) = sip_uri2parts($from); return 1 if lc($user) eq lc($auth_user); DEBUG( 10, "No Auth-success: From-user is '$user' and auth_user is '$auth_user'" ); return 0; } package Net::SIP::Authorize::ToIsFrom; use Net::SIP::Util qw( sip_hdrval2parts ); use Net::SIP::Debug; sub verify { my ($packet,$leg,$addr,$auth_user,$auth_realm) = @_; my $from = $packet->get_header('from'); ($from) = sip_hdrval2parts( from => $from ); my $to = $packet->get_header('to'); ($to) = sip_hdrval2parts( to => $to ); return 1 if lc($from) eq lc($to); DEBUG( 10, "No Auth-success: To is '$to' and From is '$from'" ); return 0; } 1; Net-SIP-0.822/lib/Net/SIP/Util.pod0000644000175100017510000002404513370543213015012 0ustar workwork =head1 NAME Net::SIP::Util - utility functions used by all of L =head1 SYNOPSIS use Net::SIP::Util qw( create_rtp_sockets ); my ($port,@socks) = create_rtp_sockets( '192.168.0.10' ) or die; =head1 DESCRIPTION This package implements various utility function used within various L packages and partly usable for the user of L too. Each of this functions is exportable, but none is exported per default. All functions can be exported at once with the import flag C<:all>. =head1 SUBROUTINES =over 4 =item invoke_callback ( CALLBACK, @ARGS ) Invokes callback CALLBACK with additional args @ARGS. CALLBACK can be: =over 8 =item A code reference In this case it will be called as C<< $CALLBACK->(@ARGS) >> and return the return value of this call. =item A reference to a scalar In this case the scalar will be set to C<< $ARGS[0] >> and the rest of @ARGS will be ignored. If no @ARGS are given the scalar will be set to TRUE. It will return with the value of the scalar. =item An object which has a method B In this case it will call C<< $CALLBACK->run(@ARGS) >> and return with the return value of this call. =item A reference to an array The first element of the array will be interpreted as code reference, while the rest as args, e.g. it will do: my ($coderef,@cb_args) = @$CALLBACK; return $coderef->( @cb_args, @ARGS ); =item A regular expression In this case it will try to match all @ARGS against the regex. If anything matches it will return TRUE, else FALSE. =back =item laddr4dst(DST) -> SRC This will try to find out which local IP address B is used for connections to target B. This will be done by creating a connected UDP socket to the target and using B to get the local IP address of this socket. =item create_socket_to ( ADDR, [ PROTO ] ) Creates socket with protocol PROTO (default 'udp'). It will use C to find the appropriate local source IP address. It will try to bind the socket to port 5060 (default SIP port). If this fails it will try port 5062..5100 and if it cannot bind to any of these ports it will just use any port which gets assigned by the OS. For multihomed hosts where several addresses are bound to the same interface it will just use one of these addresses. If you need more control about the address the socket is bound to (and which will be used as the local IP in outgoing packets) you need to create the socket yourself. In scalar context it just returns the newly created socket. In array context it will return the socket and the C<< "ip:port" >> the created socket is bound to. If the creation of the socket fails it will return C<()> and set C<$!>. Example: my ($sock,$ip_port) = create_socket_to ( '192.168.0.1' ) or die $!; =item create_rtp_sockets ( LADDR, [ RANGE, MINPORT, MAXPORT, TRIES ] ) This tries to allocate sockets for RTP. RTP consists usually of a data socket on an even port number and a control socket (RTCP) and the following port. It will try to create these sockets. MINPORT is the minimal port number to use (default 2000), MAXPORT the highest port (default MINPORT+10000), TRIES is the number of attempts it makes to create such socket pairs and defaults to 1000. RANGE is the number of consecutive ports it needs to allocate and defaults to 2 (e.g. data and control socket). Allocation will be done by choosing a random even number between MINPORT and MAXPORT and then trying to allocate all the sockets on this and the following port numbers. If the allocation fails after TRIES attempts were made it will return C<()>, otherwise it will return an array with at first the starting port number followed by all the allocated sockets. Example: my ($port,$rtp_sock,$rtcp_sock) = create_rtp_sockets( '192.168.0.10' ) or die "allocation failed"; =item sip_hdrval2parts ( KEY, VALUE ) Interprets VALUE as a value for the SIP header field KEY and splits it into the parts (prefix, parameter). Because for most keys the delimiter is C<;>, but for some keys C<,> the field name KEY need to be known. KEY needs to be normalized already (lower case, no abbreviation). Returns array with initial data (up to first delimiter) and the parameters as hash. Example for key 'to': '"Silver; John" ; tag=...; protocol=TCP' -> ( '"Silver; John" ', { tag => ..., protocol => 'TCP' } ) Example for key 'www-authenticate': 'Digest method="md5", qop="auth"' -> ( 'Digest', { method => 'md5', qop => 'auth' } ) =item sip_parts2hdrval ( KEY, PREFIX, \%PARAMETER ) Inverse function to B, e.g constructs header value for KEY from PREFIX and %PARAMETER and returns value. =item sip_uri2parts(URI) -> (DOMAIN, USER, PROTO, PARAM, DATA) | DOMAIN Returns parts from URI. If called in scalar context it returns only the domain part. In array context it returns an array with the following values: =over 4 =item DOMAIN The lower cased domain part as given in the URI, i.e. C, C, C<[ipv6]:port> etc. =item USER The optional user part of the SIP address. =item PROTO The protocol, e.g. C or C. If not explicitly given it will default to C. =item PARAM A hash reference to any parameters following C as returned by B. =item DATA The original full part before any parameter, i.e. the part containing the domain, optional user and optional proto. =back =item sip_parts2uri(DOMAIN, USER, PROTO, PARAM) -> URI Returns URI from parts, i.e. the reverse to B. For the meaning of the parameters see there. =item sip_uri2sockinfo(URI; OPAQUE) -> (PROTO, HOST, PORT, FAMILY) This extracts information from B which are needed for creating the socket: B is the IP address or host name, B the port (undef if not given) and B the family, i.e. AF_INET, AF_INET6 or undef if B is not an IP address. B will be set based on the SIP protocol and parameters, i.e. C for C URI, C or C for C URI with explicit C parameter and C otherwise. If B the host name is not required to be a valid name. See B in C for more information. =item sip_sockinfo2uri(PROTO, HOST, PORT, FAMILY) -> URI This is the reverse to B. See there for the meaning of the parameters. If the first argument is a hash ref it will expected to provided the arguments in the keys C, C, C and C. =item sip_uri_eq ( URI1, URI2 ) Returns true if both URIs point to the same SIP address. This compares user part case sensitive, domain part case insensitive (does no DNS resolution) protocol and ports in domain (assumes default ports for protocol if no port is given). =item ip_string2parts(STR;OPAQUE) -> (HOST, PORT, FAMILY) | \%HASH This will parse the given string STR and split it into the parts as follows: IPv4, [IPv4] -> (IPv4, undef, AF_INET) IPv4:port, [IPv4]:port -> (IPv4, port, AF_INET) IPv6, [IPv6] -> (IPv6, undef, AF_INET6) [IPv6]:port -> (IPv6, port, AF_INET6) host, [host] -> (host, undef, undef) host:port, [host]:port -> (host, port, undef) The IP address and host will be returned in a canonicalized way. If this function is used to parse strings where the host part is not a real hostname but some identifier with more allowed characters than a hostname then OPAQUE should be set and in this way no strict checking and no canonicalization is done. If the function is called with a scalar context it will return the result as a hash ref with the keys C, C, C, C where C is only set if it is IP address. =item ip_parts2string(HOST, [ PORT, FAMILY, IPv6_BRCKT]) -> STR This is the reverse to ip_string2parts. If family is not given it will be determined by checking if ip_or_host contains ':' (i.e IPv6 address): (ip_or_host) -> ip_or_host (ipv4_or_host,port) -> ipv4_or_host:port (ipv6,port) -> [ipv6]:port (ipv6,undef,*,true) -> [ipv6] If the first argument is a hash ref it will be treated as a hash ref as returned by B. In this case also C can be given which prefers C to C for stringification. Also, C can be used to give a port number which will be treated as default and omitted from string. =item ip_sockaddr2parts(SOCKADDR, [FAMILY]) -> (IP, PORT, FAMILY) This will return the IP, PORT and FAMILY from a sockaddr_in or sockaddr_in6. If FAMILY is not given it will be determined based on the size of SOCKADDR. If the function is called with a scalar context it will return the result as a hash ref as described for B. =item ip_parts2sockaddr(IP, PORT, [FAMILY]) -> SOCKADDR This will create a sockaddr_in or sockaddr_in6 from IP and PORT. FAMILY will be determined by checking the IP if not given. If the first argument is a hash ref it will be treated as a hash ref as returned by B. =item ip_sockaddr2string(SOCKADDR, [FAMILY]) -> STR This will return the STR from a sockaddr_in or sockaddr_in6, i.e. like combining C with C. If FAMILY is not given it will be determined based on the size of SOCKADDR. =item ip_ptr(IP, [FAMILY]) -> PTR_NAME This will create the hostname used in reverse lookup of an IP address, i.e. C<*.in-addr.arpa> or C<*.ip6.arpa>. If FAMILY is not given it will be determined based on the syntax of IP. =item ip_canonical(IP, [FAMILY]) -> IP This will convert the given IP address into a canonical form suitable for comparison. =item hostname2ip(host, [FAMILY]) -> @IP This will lookup the given name using getaddrinfo and return the IP addresses. If FAMILY is given only addresses matching the family will be returned. =item ip_is_v4(IP) -> true|false This checks if the given IP address is a valid IPv4 address. =item ip_is_v6(IP) -> true|false This checks if the given IP address is a valid IPv6 address. =item ip_is_v46(IP) -> AF_INET|AF_INET6|undef This checks if the given IP address is a valid IPv4 or IPv6 address and returns the address family if this is an IP address. =back Net-SIP-0.822/lib/Net/SIP/Debug.pm0000644000175100017510000002121013205223360014737 0ustar workworkpackage Net::SIP::Debug; use strict; use warnings; use Carp; use Data::Dumper; use Time::HiRes 'gettimeofday'; use Scalar::Util 'looks_like_number'; use base 'Exporter'; our @EXPORT = qw( DEBUG DEBUG_DUMP LEAK_TRACK $DEBUG ); our @EXPORT_OK = qw( debug stacktrace ); our $DEBUG = 0; # exported fast check: if false no kind of debugging is done our $level = 0; # needed global for source filter my %level4package; # package specific level my $debug_prefix = 'DEBUG:'; # default prefix my $debug_sub; # alternative sub to STDERR output ############################################################## # set level, scope etc from use. Usually used at the # start, e.g. perl -MNet::SIP::Debug=level program # Args: @args # @args: something for sub level, rest to Exporter # Returns: NONE ############################################################## sub import { my $class = shift; my (@export,@level); for (@_) { if ( ref eq 'CODE' ) { # set debug sub $debug_sub = $_; } elsif ( m{[=\*]} || m{^\d} || m{::} ) { push @level,$_ } else { push @export,$_ } } $class->level(@level) if @level; $class->export_to_level(1,@export) if @export; $class->export_to_level(1) if ! @export && ! @level; } ############################################################## # set/get debug level # Args: ($class,@spec) # @spec: number|package|package=number for setting # global|package specific debug level. If package # is postfixed with '*' the level will be used for # subpackages too. # Returns: NONE|level # level: if not @spec level for the current package # (first outside Net::SIP::Debug in caller stack) will # be returned ############################################################## sub level { shift; # class if ( @_ ) { my @level = @_ >1 ? split( m{[^\w:=\*]+}, $_[0] ): @_; foreach (@level) { if ( m{^\d+$} ) { $level = $_; } elsif ( m{^([\w:]+)(\*)?(?:=(\d+))?$} ) { # package || package=level my $l = defined($3) ? $3: $level || 1; my $name = $1; my $below = $2; my @names = ( $name ); push @names, "Net::".$name if $name =~ m{^SIP\b}; push @names, "Net::SIP::".$name if $name !~ m{^Net::SIP\b}; foreach (@names) { $level4package{$_} = $l; $level4package{$_.'::'} = $l if $below; } } } $DEBUG = grep { $_>0 } ($level, values(%level4package)); } else { # check $DEBUG or return 0; if ( %level4package ) { # check if there is a specific level for this package my $pkg; for( my $i=0;1;$i++ ) { # find first frame outside of this package ($pkg) = caller($i); last if !$pkg or $pkg ne __PACKAGE__; } return $level if !$pkg; # find exakt match my $l = $level4package{$pkg}; return $l if defined($l); # find match for upper packages, e.g. if there is an entry for # 'Net::SIP::' it matches everything below Net::SIP while ( $pkg =~s{::\w+(::)?$}{::} ) { return $l if defined( $l = $level4package{$pkg} ); } } } return $level } ################################################################ # set prefix # default prefix is 'DEBUG:' but in forking apps it might # be useful to change it to "DEBUG($$):" or similar # Args: $class,$prefix # Returns: NONE ################################################################ sub set_prefix { (undef,$debug_prefix) = @_ } ################################################################ # write debug output if debugging enabled for caller # Args: ?$level, ( $message | $fmt,@arg ) # $level: if first arg is number it's interpreted as debug level # $message: single message # $fmt: format for sprintf # @arg: arguments for sprintf after format # Returns: NONE ################################################################ sub DEBUG { goto &debug } sub debug { $DEBUG or return; my $level = __PACKAGE__->level || return; my $prefix = $debug_prefix; if (@_>1 and looks_like_number($_[0])) { my $when = shift; return if $when>$level; $prefix .= "<$when>"; } my ($msg,@arg) = @_; return if !defined($msg); if ( 1 || $msg !~ m{^\w+:} ) { # Message hat keinen eigenen "Prefix:", also mit Funktion[Zeile] prefixen my ($sub) = (caller(1))[3]; my $line = (caller(0))[2]; $sub =~s{^main::}{} if $sub; $sub ||= 'Main'; $msg = "$sub\[$line]: ".$msg; } if ( @arg ) { # $msg als format-string für sprintf ansehen no warnings 'uninitialized'; $msg = sprintf($msg,@arg); } # if $debug_sub use this return $debug_sub->($msg) if $debug_sub; # alle Zeilen mit DEBUG: prefixen $prefix = sprintf "%.4f %s",scalar(gettimeofday()),$prefix; $msg = $prefix." ".$msg; $msg =~s{\n}{\n$prefix\t}g; return $msg if defined wantarray; # don't print $msg =~s{[^[:space:][:print:]]}{_}g; print STDERR $msg,"\n"; } ################################################################ # Dumps structure if debugging enabled # Args: ?$level,@data # $level: if first arg is number it's interpreted as debug level # @data: what to be dumped, if @data>1 will dump \@data, else $data[0] # Returns: NONE ################################################################ sub DEBUG_DUMP { $DEBUG or return; my $level = __PACKAGE__->level || return; my $when; if (@_>1 and looks_like_number($_[0])) { $when = shift; return if $when>$level; } @_ = Dumper( @_>1 ? \@_:$_[0] ); unshift @_,$when if defined $when; goto &debug; } ################################################################ # return stacktrace # Args: $message | $fmt,@arg # Returns: $stacktrace # $stacktrace: stracktrace including debug info from args ################################################################ sub stacktrace { return Carp::longmess( debug(@_) ); } ################################################################ # helps to track leaks, e.g. where refcounts will never go to # zero because of circular references... # will build proxy object around reference and will inform when # LEAK_TRACK is called or when object gets destroyed. If Devel::Peek # is available it will Devel::Peek::Dump the object on each # LEAK_TRACK (better would be to just show the refcount of the # reference inside the object, but Devel::Peek dumps to STDERR # and I didn't found any other package to provide the necessary # functionality) # Args: $ref # Returns: $ref # $ref: reblessed original reference if not reblessed yet ################################################################ sub LEAK_TRACK { my $class = ref($_[0]); my $leak_pkg = '__LEAK_TRACK__'; my ($file,$line) = (caller(0))[1,2]; my $count = Devel::Peek::SvREFCNT($_[0]); if ( $class =~m{^$leak_pkg} ) { # only print info warn "$_[0] +++ refcount($count) tracking from $file:$line\n"; Devel::Peek::Dump($_[0],1); return $_[0]; } unless ( $class eq 'HASH' || $class eq 'ARRAY' || $class eq 'SCALAR' ) { # need to create wrapper package ? $leak_pkg .= '::'.$class; if ( ! UNIVERSAL::can( $leak_pkg, 'DESTROY' )) { eval <SUPER::DESTROY; } EOL die $@ if $@; } } bless $_[0], $leak_pkg; warn "$_[0] +++ refcount($count) starting tracking called from $file:$line\n"; Devel::Peek::Dump($_[0],1); return $_[0]; } { package __LEAK_TRACK__; sub DESTROY { my ($file,$line) = (caller(0))[1,2]; warn "$_[0] --- destroy in $file:$line\n"; } } eval 'require Devel::Peek'; if ( $@ ) { # cannot be loaded *{ 'Devel::Peek::Dump' } = sub {}; *{ 'Devel::Peek::SvREFCNT' } = sub { 'unknown' }; } =for experimental_use_only # works, but startup of programs using this is noticably slower, therefore # not enabled by default use Filter::Simple; FILTER_ONLY( code => sub { # replace DEBUG(...) with # - if Debug::level around it (faster, because expressions inside debug # get only evaluated if debugging is active) # - no warnings for expressions, because in often debug messages # are quick and dirty # FIXME: do it for DEBUG_DUMP too # cannot use Text::Balanced etc because placeholder might contain ')' which # should not be matched my $code = ''; { local $_ = $_; # copy while (1) { $code .= s{\ADEBUG\s*\(}{}s ? '' : s{\A(.*?[^\w:])DEBUG\s*\(}{}s ? $1 : last; my $level = 1; my $inside = ''; while ( s{\A((?:$Filter::Simple::placeholder|.)*?)([()])}{}s ) { $inside .= $1; $level += ( $2 eq '(' ) ? +1:-1; last if !$level; $inside .= $2; } $level && die "unbalanced brackets in DEBUG(..)"; $code .= "if (\$Debug::level) { no warnings; Debug::debug($inside) }"; } $code .= $_; # rest } $_ = $code; }); =cut 1; Net-SIP-0.822/lib/Net/SIP/StatelessProxy.pm0000644000175100017510000006100013551637244016741 0ustar workwork########################################################################### # Net::SIP::StatelessProxy # implements a simple stateless proxy # all packets will be forwarded between Leg#1 to Leg#2. If there is # only one leg it will use only this leg. ########################################################################### use strict; use warnings; package Net::SIP::StatelessProxy; use fields qw( dispatcher rewrite_contact nathelper force_rewrite respcode ); use Net::SIP::Util ':all'; use Digest::MD5 qw(md5); use Carp 'croak'; use List::Util 'first'; use Hash::Util 'lock_ref_keys'; use Net::SIP::Debug; ########################################################################### # creates new stateless proxy # Args: ($class,%args) # %args # dispatcher: the Net::SIP::Dispatcher object managing the proxy # rewrite_contact: callback to rewrite contact header. If called with from header # it should return a string of form \w+. If called # again with this string it should return the original header back. # if called on a string without @ which cannot rewritten back it # should return undef. If not given a reasonable default will be # used. # rewrite_crypt: function(data,dir,add2mac) which will encrypt(dir>0) or # decrypt(dir<0) data. Optional add2mac is added in MAC. Will return # encrypted/decrypted data or undef if decryption failed because # MAC did not match # nathelper: Net::SIP::NAT::Helper used for rewrite SDP bodies.. (optional) # force_rewrite: if true rewrite contact even if incoming and outgoing # legs are the same # Returns: $self ########################################################################### sub new { my ($class,%args) = @_; my $self = fields::new( $class ); my $disp = $self->{dispatcher} = delete $args{dispatcher} || croak 'no dispatcher given'; $self->{rewrite_contact} = delete $args{rewrite_contact} || do { my $crypt = $args{rewrite_crypt} || \&_stupid_crypt; [ \&_default_rewrite_contact, $crypt, $disp ]; }; $self->{nathelper} = delete $args{nathelper}; $self->{force_rewrite} = delete $args{force_rewrite}; $self->{respcode} = [ {},{} ]; return $self; } # default handler for rewriting, does simple XOR only, # this is not enough if you need to hide internal addresses sub _default_rewrite_contact { my ($crypt,$disp,$contact,$leg_in,$leg_out,$force_rewrite) = @_; my $legdict; my ($ileg_in,$ileg_out) = $disp->legs2i($leg_in,$leg_out,\$legdict); if ($force_rewrite or $contact =~m{\@}) { # needs to be rewritten - incorporate leg_in:leg_out $contact = pack("nna*",$ileg_in,$ileg_out,$contact); # add 'b' in front so it does not look like phone number my $new = 'b'._encode_base32($crypt->($contact,1,$legdict)); DEBUG( 100,"rewrite $contact -> $new" ); return $new; } if ( $contact =~m{^b([A-Z2-7]+)$} ) { # needs to be written back my $old = $crypt->(_decode_base32($1),-1,$legdict) or do { DEBUG(10,"no rewriting of $contact - bad encryption"); return; }; DEBUG(100,"rewrote back $contact -> $old"); (my $iold_in,my $iold_out,$old) = unpack("nna*",$old); if ($ileg_in ne $iold_out) { my ($old_out) = $disp->i2legs($iold_out); if ($leg_in->{contact} ne $old_out->{contact} && ! sip_uri_eq($leg_in->{contact},$old_out->{contact})) { DEBUG(10, "no rewriting of %s - went out through %s, came in through %s", $contact, $old_out->{contact}, $leg_in->{contact}); return; } } if ( ref($leg_out) eq 'SCALAR' ) { # return the old_in as the new outgoing leg ($$leg_out) = $disp->i2legs($iold_in) or do { DEBUG(10,"no rewriting of $contact - cannot find leg $iold_in"); return; } } elsif ($leg_out) { # check that it is the expected leg if ($ileg_out ne $iold_in) { my ($old_in) = $disp->i2legs($iold_in); if ($leg_out->{contact} ne $old_in->{contact} && ! sip_uri_eq($leg_out->{contact},$old_in->{contact})) { DEBUG(10, "no rewriting of %s - went in through %s, should got out through %s", $contact, $old_in->{contact}, $leg_out->{contact}); return; } } } DEBUG( 100,"rewrite back $contact -> $old" ); return $old; } # invalid format DEBUG( 100,"no rewriting of $contact" ); return; } { # This is only a simple implementation which is in no way cryptographic safe # because it does use a broken cipher (RC4), pseudo-random keys and IV only # and short keys. Nonetheless, it is probably safe for this purpose and does # not depend on non-standard libs, but using openssl bindings might be both # more secure and faster for this. # # RC4 with seed + checksum, picks random key on first use # dir: encrypt(1),decrypt(-1), otherwise symmetric w/o seed and checksum my (@k,$mackey); sub _stupid_crypt { my ($in,$dir,$add2mac) = @_; $add2mac = '' if ! defined $add2mac; if (!@k) { # create random key @k = map { rand(256) } (0..20); $mackey = pack("N",rand(2**32)); } if ($dir>0) { $in = pack("N",rand(2**32)).$in; # add seed } else { # remove checksum and verify it my $cksum = substr($in,-4,4,''); substr(md5($in.$add2mac.$mackey),0,4) eq $cksum or return; # does not match } # apply RC4 for encryption/decryption my $out = ''; my @s = (0..255); my $x = my $y = 0; for(0..255) { $y = ( $k[$_%@k] + $s[$x=$_] + $y ) % 256; @s[$x,$y] = @s[$y,$x]; } $x = $y = 0; for(unpack('C*',$in)) { $x++; $y = ( $s[$x%=256] + $y ) % 256; @s[$x,$y] = @s[$y,$x]; $out .= pack('C',$_^=$s[($s[$x]+$s[$y])%256]); } if ($dir>0) { # add checksum $out .= substr(md5($out.$add2mac.$mackey),0,4); } else { substr($out,0,4,''); # remove seed } return $out; } sub _encode_base32 { my $data = shift; $data = unpack('B*',$data); my $text; my $padsize = $data .= '0' x ((5 - length($data) % 5) % 5); # padding $data =~s{(.....)}{000$1}g; $data = pack('B*',$data); $data =~tr{\000-\037}{A-Z2-7}; return $data; } sub _decode_base32 { my $data = shift; $data =~ tr{A-Z2-7a-z}{\000-\037\000-\031}; $data = unpack('B*',$data); $data =~s{...(.....)}{$1}g; $data = substr($data,0,8*int(length($data)/8)); return pack('B*',$data); } } ########################################################################### # handle incoming packets # Args: ($self,$packet,$leg,$from) # $packet: Net::SIP::Packet # $leg: incoming leg # $from: ip:port where packet came from # Returns: TRUE if packet was fully handled ########################################################################### sub receive { my Net::SIP::StatelessProxy $self = shift; my ($packet,$incoming_leg,$from) = @_; DEBUG( 10,"received ".$packet->dump ); # Prepare for forwarding, e.g adjust headers # (add record-route) if ( my $err = $incoming_leg->forward_incoming( $packet )) { my ($code,$text) = @$err; DEBUG( 10,"ERROR while forwarding: $code, $text" ); return; } my $rewrite_contact = $self->{rewrite_contact}; my $disp = $self->{dispatcher}; # find out how to forward packet my %entry = ( packet => $packet, incoming_leg => $incoming_leg, from => $from, outgoing_leg => [], dst_addr => [], nexthop => undef, ); if ( $packet->is_response ) { # find out outgoing leg by checking (and removing) top via if ( my ($via) = $packet->get_header( 'via' )) { my ($data,$param) = sip_hdrval2parts( via => $via ); my $branch = $param->{branch}; if ( $branch ) { my @legs = $self->{dispatcher}->get_legs( sub => sub { my $lb = shift->{branch}; $lb eq substr($branch,0,length($lb)); }); if (@legs) { $entry{outgoing_leg} = \@legs; # remove top via, see Leg::forward_incoming my $via; $packet->scan_header( via => [ sub { my ($vref,$hdr) = @_; if ( !$$vref ) { $$vref = $hdr->{value}; $hdr->remove; } }, \$via ]); } } } __forward_response( $self, \%entry ); } else { # check if the URI was handled by rewrite_contact # this is the case where the Contact-Header was rewritten # (see below) and a new request came in using the new # contact header. In this case we need to rewrite the URI # to reflect the original contact header my ($to) = sip_hdrval2parts( uri => $packet->uri ); $to = $1 if $to =~m{<(\w+:\S+)>}; if ( my ($pre,$name) = $to =~m{^(sips?:)(\S+)?\@} ) { my $outgoing_leg; if ( my $back = invoke_callback( $rewrite_contact,$name,$incoming_leg,\$outgoing_leg )) { $to = $pre.$back; DEBUG( 10,"rewrote URI from '%s' back to '%s'", $packet->uri, $to ); $packet->set_uri( $to ); $entry{outgoing_leg} = [ $outgoing_leg ] if $outgoing_leg; } } $self->__forward_request_getleg( \%entry ); } } ########################################################################### # Get destination address from Via: header in response # Calls __forward_response_1 either directly or after resolving hostname # of destination to IP ########################################################################### sub __forward_response { my Net::SIP::StatelessProxy $self = shift; my $entry = shift; my $packet = $entry->{packet}; # find out where to send packet by parsing the upper via # which should contain the addr of the next hop my ($via) = $packet->get_header( 'via' ) or do { DEBUG( 10,"no via header in packet. DROP" ); return; }; my ($first,$param) = sip_hdrval2parts( via => $via ); $first =~m{^SIP/\d\.\d(?:/(\S+))?\s+(.*)}; my $proto = lc($1) || 'udp'; my ($host,$port,$family) = ip_string2parts($2); my $addr = $family && $host; $port ||= $proto eq 'tls' ? 5061 : 5060; if (my $alt_addr = $param->{received} || $param->{maddr}) { my $alt_fam = ip_is_v46($alt_addr); if ($alt_fam) { $addr = $alt_addr; $family = $alt_fam; } else { DEBUG(10,"ignoring maddr/received because of invalid IP $alt_addr"); } } $port = $param->{rport} if $param->{rport}; # where it came from my $nexthop = lock_ref_keys({ proto => $proto, host => $host || $addr, addr => $addr, port => $port, family => $family }); if ($addr) { @{$entry->{dst_addr}} = $nexthop; $DEBUG && DEBUG(50, "get dst_addr from via header: %s -> %s", $first, ip_parts2string($nexthop)); return __forward_response_1($self,$entry); } return $self->{dispatcher}->resolve_uri( sip_sockinfo2uri($nexthop), $entry->{dst_addr}, $entry->{outgoing_leg}, [ \&__forward_response_1,$self,$entry ], undef, ); } ########################################################################### # Called from _forward_response directly or indirectly after resolving # hostname of destination. # Calls __forward_packet_final at the end to deliver packet ########################################################################### sub __forward_response_1 { my Net::SIP::StatelessProxy $self = shift; my $entry = shift; if (@_) { $DEBUG && DEBUG( 10,"cannot resolve address %s: @_", ip_parts2string($entry->{dst_addr}[0])); return; } $self->__forward_packet_final($entry); } ########################################################################### # Forwards request # try to find outgoing_leg from Route header # if there are more Route headers it picks the destination address from next ########################################################################### sub __forward_request_getleg { my Net::SIP::StatelessProxy $self = shift; my $entry = shift; # if the top route header points to a local leg we use this as outgoing leg my @route = $entry->{packet}->get_header('route'); if ( ! @route ) { DEBUG(50,'no route header'); return $self->__forward_request_getdaddr($entry) } my $route = $route[0] =~m{<([^\s>]+)>} && $1 || $route[0]; my $ol = $entry->{outgoing_leg}; if ( $ol && @$ol ) { if ( sip_uri_eq( $route,$ol->[0]{contact})) { DEBUG(50,"first route header matches choosen leg"); shift(@route); } else { DEBUG(50,"first route header differs from choosen leg"); } } else { my ($data,$param) = sip_hdrval2parts( route => $route ); my ($proto, $addr, $port, $family) = sip_uri2sockinfo($data, $param->{maddr} ? 1:0); $port ||= $proto eq 'tls' ? 5061 : 5060; my @legs = $self->{dispatcher}->get_legs( addr => $addr, port => $port, family => $family); if ( ! @legs and $param->{maddr} ) { @legs = $self->{dispatcher}->get_legs( addr => $param->{maddr}, port => $port ); } if ( @legs ) { DEBUG( 50,"setting leg from our route header: $data -> ".$legs[0]->dump ); $entry->{outgoing_leg} = \@legs; shift(@route); } else { DEBUG( 50,"no legs which can deliver to $addr:$port (route)" ); } } if ( @route ) { # still routing infos. Use next route as nexthop my ($data,$param) = sip_hdrval2parts( route => $route[0] ); $entry->{nexthop} = $data; DEBUG(50, "setting nexthop from route $route[0] to $entry->{nexthop}"); } return $self->__forward_request_getdaddr($entry) } ########################################################################### # Forwards request # try to find dst addr # if it does not have destination address tries to resolve URI and then # calls __forward_request_1 ########################################################################### sub __forward_request_getdaddr { my Net::SIP::StatelessProxy $self = shift; my $entry = shift; return __forward_request_1( $self,$entry ) if @{ $entry->{dst_addr}}; $entry->{nexthop} ||= $entry->{packet}->uri, DEBUG(50,"need to resolve $entry->{nexthop}"); return $self->{dispatcher}->resolve_uri( $entry->{nexthop}, $entry->{dst_addr}, $entry->{outgoing_leg}, [ \&__forward_request_1,$self,$entry ], undef, ); } ########################################################################### # should have dst_addr now, but this might be still with non-IP hostname # resolve it and go to __forward_request_2 or directly to __forward_packet_final ########################################################################### sub __forward_request_1 { my Net::SIP::StatelessProxy $self = shift; my $entry = shift; if (@_) { DEBUG(10,"failed to resolve URI %s: @_",$entry->{nexthop}); return; } my $dst_addr = $entry->{dst_addr}; if ( ! @$dst_addr ) { DEBUG( 10,"cannot find dst for uri ".$entry->{packet}->uri ); return; } my %hostnames; foreach (@$dst_addr) { ref($_) or Carp::confess("expected reference: $_"); $hostnames{$_->{host}} = $_->{host} if ! $_->{addr}; } if ( %hostnames ) { $self->{dispatcher}->dns_host2ip( \%hostnames, [ \&__forward_request_2,$self,$entry ] ); } else { $self->__forward_packet_final($entry); } } ########################################################################### # called after hostname for destination address got resolved # calls __forward_packet_final ########################################################################### sub __forward_request_2 { my Net::SIP::StatelessProxy $self = shift; my ($entry,$errno,$host2ip) = @_; my $dst_addr = $entry->{dst_addr}; while ( my ($host,$ip) = each %$host2ip ) { unless ( $ip ) { DEBUG( 10,"cannot resolve address $host" ); @$dst_addr = grep { $_->{host} ne $host } @$dst_addr; next; } else { DEBUG( 50,"resolved $host -> $ip" ); $_->{addr} = $ip for grep { $_->{host} eq $host } @$dst_addr; } } return unless @$dst_addr; # nothing could be resolved $self->__forward_packet_final($entry); } ########################################################################### # dst_addr is known and IP # if no legs given use the one which can deliver to dst_addr # if there are more than one try to pick best based on protocol # but finally pick simply the first # rewrite contact header # call forward_outgoing on the outgoing_leg # and finally deliver the packet ########################################################################### sub __forward_packet_final { my ($self,$entry) = @_; my $dst_addr = $entry->{dst_addr}; my $legs = $entry->{outgoing_leg}; if ( !@$legs == @$dst_addr ) { # get legs from dst_addr my @all_legs = $self->{dispatcher}->get_legs; @$legs = (); my @addr; foreach my $addr (@$dst_addr) { my $leg = first { $_->can_deliver_to(%$addr) } @all_legs; if ( ! $leg ) { DEBUG( 50,"no leg for $addr" ); next; } push @addr,$addr; push @$legs,$leg } @$dst_addr = @addr; @$legs or do { DEBUG( 10,"cannot find any legs" ); return; }; } my $incoming_leg = $entry->{incoming_leg}; if ( @$legs > 1 ) { if ( $incoming_leg->{proto} eq 'tcp' ) { # prefer tcp legs my @tcp_legs = grep { $_->{proto} eq 'tcp' } @$legs; @$legs = @tcp_legs if @tcp_legs; } } # pick first my $outgoing_leg = $legs->[0]; $dst_addr = $dst_addr->[0]; my $packet = $entry->{packet}; # rewrite contact header if outgoing leg is different to incoming leg if ( ( $outgoing_leg != $incoming_leg or $self->{force_rewrite} ) and (my @contact = $packet->get_header( 'contact' ))) { my $rewrite_contact = $self->{rewrite_contact}; foreach my $c (@contact) { # rewrite all sip(s) contacts my ($data,$p) = sip_hdrval2parts( contact => $c ); my ($pre,$addr,$post) = $data =~m{^(.*\s]+)(>.*)}i ? ($1,$2,$3) : $data =~m{^(sips?:)([^>\s]+)$}i ? ($1,$2,'') : next; # if contact was rewritten rewrite back if ( $addr =~m{^(\w+)(\@.*)} and my $newaddr = invoke_callback( $rewrite_contact,$1,$incoming_leg,$outgoing_leg)) { my $cnew = sip_parts2hdrval( 'contact', $pre.$newaddr.$post, $p ); DEBUG( 50,"rewrote back '$c' to '$cnew'" ); $c = $cnew; # otherwise rewrite it } else { $addr = invoke_callback($rewrite_contact,$addr,$incoming_leg, $outgoing_leg,1); $addr .= '@'.$outgoing_leg->laddr(2); my $cnew = sip_parts2hdrval( 'contact', $pre.$addr.$post, $p ); DEBUG( 50,"rewrote '$c' to '$cnew'" ); $c = $cnew; } } $packet->set_header( contact => \@contact ); } if ( $outgoing_leg != $incoming_leg and $packet->is_request ) { $incoming_leg->add_via($packet); } # prepare outgoing packet if ( my $err = $outgoing_leg->forward_outgoing( $packet,$incoming_leg )) { my ($code,$text) = @$err; DEBUG( 10,"ERROR while forwarding: ".( defined($code) ? "$code, $text" : $text )); return; } if ( my $err = $self->do_nat( $packet,$incoming_leg,$outgoing_leg ) ) { my ($code,$text) = @$err; DEBUG( 10,"ERROR while doing NAT: $code, $text" ); return; } # Just forward packet via the outgoing_leg $self->{dispatcher}->deliver( $packet, leg => $outgoing_leg, dst_addr => $dst_addr, do_retransmits => 0 ); } ############################################################################ # If a nathelper is given try to rewrite SDP bodies. If this fails # (not enough resources) just drop packet, the sender will retry later # (FIXME: this is only true in case of UDP, but not TCP) # # Args: ($self,$packet,$incoming_leg,$outgoing_leg) # $packet: packet to forward # $incoming_leg: where packet came in # $outgoing_leg: where packet will be send out # Returns: $error # $error: undef | [ $code,$text ] ############################################################################ sub do_nat { my Net::SIP::StatelessProxy $self = shift; my ($packet,$incoming_leg,$outgoing_leg) = @_; my $nathelper = $self->{nathelper} || do { DEBUG( 100, "no nathelper" ); return; }; # no NAT if outgoing leg is same as incoming leg if ( $incoming_leg == $outgoing_leg ) { DEBUG( 100,"no NAT because incoming leg is outgoing leg" ); return; } my $body = eval { $packet->cseq =~m{\b(?:INVITE|ACK)\b} && $packet->sdp_body }; if ( $@ ) { DEBUG( 10, "malformed SDP body" ); return [ 500,"malformed SDP body" ]; } my ($request,$response) = $packet->is_request ? ( $packet,undef ) : ( undef,$packet ) ; my $method = $request ? $request->method : ''; my $track_resp_code; if ($response and $response->method eq 'INVITE') { my $code = $response->code; $track_resp_code = $code if $code>=400; } # NAT for anything with SDP body # activation and close of session will be done on ACK|CANCEL|BYE unless ( $body or $method eq 'ACK' or $method eq 'CANCEL' or $method eq 'BYE' ) { DEBUG( 100, "no NAT because no SDP body and method is $method" ); return if ! $track_resp_code; } # find NAT data for packet: # $idfrom and $idto are the IDs for FROM|TO which consist of # the SIP address + (optional) Tag + Contact-Info from responsable # Leg, delimited by "\0" my ($idfrom,$idto); for([from => \$idfrom], [to => \$idto]) { my ($k,$idref) = @$_; if (my $v = $packet->get_header($k) ) { my ($uri,$param) = sip_hdrval2parts(from => $v); my ($dom,$user,$proto) = sip_uri2parts($uri); $$idref = "$proto:$user\@$dom\0".($param->{tag} || ''); } else { return [ 0,'no '.uc($k).' header in packet' ] } } # side is either 0 (request) or 1 (response) # If a request comes in 'from' points to the incoming_leg while # 'to' points to the outgoing leg. For responses it's the other # way around my $side; my $ileg = $incoming_leg->laddr(1); my $oleg = $outgoing_leg->laddr(1); if ( $request ) { $idfrom .= "\0".$ileg; $idto .= "\0".$oleg; $side = 0; } else { $idfrom .= "\0".$oleg; $idto .= "\0".$ileg; $side = 1; } my ($cseq) = $packet->get_header( 'cseq' ) =~m{^(\d+)} or return [ 0,'no CSEQ in packet' ]; my $callid = $packet->callid; if ($track_resp_code) { my $rc = $self->{respcode}[0]; if (keys(%$rc)>5000) { # expire entries $self->{respcode}[1] = $rc; $rc = $self->{respcode}[0] = {}; } $rc->{$callid,$cseq,$idfrom,$idto} = $track_resp_code; # No NAT to do, we just needed to track the response code # The session should be closed though since it will not be completed DEBUG( 50,"close session $callid|$cseq because of ".( $request ? $method : $response->code." $method")); $nathelper->close_session( $callid,$cseq,$idfrom,$idto ); return; } # CANCEL|BYE will be handled first to close session # no NAT will be done, even if the packet contains SDP (which makes no sense) if ( $method eq 'CANCEL' ) { # keep cseq for CANCEL DEBUG( 50,"close session $callid|$cseq because of CANCEL" ); $nathelper->close_session( $callid,$cseq,$idfrom,$idto ); return; } elsif ( $method eq 'BYE' ) { # no cseq for BYE, eg close all sessions in call DEBUG( 50,"close call $callid because of BYE" ); $nathelper->close_session( $callid,undef,$idfrom,$idto ); return; } if ( $body ) { DEBUG( 100,"need to NAT SDP body: ".$body->as_string ); DEBUG( 50,"allocate sockets $callid|$cseq because of SDP body in ".($request ? $method : $response->code)); my $new_media = $nathelper->allocate_sockets( $callid,$cseq,$idfrom,$idto,$side,$outgoing_leg->laddr(0), scalar( $body->get_media) ); if ( ! $new_media ) { DEBUG( 10,"allocation of RTP session failed for $callid|$cseq $idfrom|$idto|$side" ); return [ 0,'allocation of RTP sockets failed' ]; } $body->replace_media_listen( $new_media ); $packet->set_body( $body ); DEBUG( 100, "new SDP body: ".$body->as_string ); } # Try to activate session as early as possible (for early data). # In a lot of cases this will be too early, because I only have one # site, but only in the case of ACK an incomplete session is invalid. if ( $method eq 'ACK' ) { my $code = $self->{respcode}[0]{$callid,$cseq,$idfrom,$idto} || $self->{respcode}[1]{$callid,$cseq,$idfrom,$idto} || -1; if ($code > 400) { # ACK to response with error code, should be closed already DEBUG( 100, "session $callid|$cseq $idfrom -> ACK to failure response" ); } elsif (! $nathelper->activate_session($callid,$cseq,$idfrom,$idto)) { DEBUG( 50,"session $callid|$cseq $idfrom -> $idto still incomplete in ACK" ); return [ 0,'incomplete session in ACK' ] } } elsif (! $nathelper->activate_session($callid,$cseq,$idfrom,$idto)) { # ignore problem, session not yet complete DEBUG( 100, "session $callid|$cseq $idfrom -> $idto not yet complete" ); } else { DEBUG( 50,"activated session $callid|$cseq $idfrom -> $idto" ) } return; } ############################################################################ # convert idside (idfrom,idto) to hash # Args: ?$class,$idside # Returns: \%hash # %hash: extracted info with keys address (sip address), tag, leg (ip:port) ############################################################################ sub idside2hash { my $idside = pop; my %hash; @hash{qw/ address tag leg /} = split( "\0",$idside,3 ); return \%hash; } 1; Net-SIP-0.822/lib/Net/SIP/Packet.pod0000644000175100017510000001410413013325411015267 0ustar workwork =head1 NAME Net::SIP::Packet - handling of SIP packets =head1 SYNOPSIS use Net::SIP::Packet; use Net::SIP::Request; use Net::SIP::Response; my $pkt = eval { Net::SIP::Packet->new( $sip_string ) } or die "invalid SIP packet"; $pkt->get_header( 'call-id' ) || die "no call-id"; $pkt->set_header( via => \@via ); print $pkt->as_string; =head1 DESCRIPTION This module implements the parsing, manipulation and creation of SIP packets according to RFC3261. NET::SIP::Packet's objects can be created by parsing a string containing the SIP packet or by constructing it from parts, e.g. header keys and values, body, method+URI (requests) or code+text (responses). All parts can be manipulated and finally the string representation of the manipulated packet can be (re)created. For dealing with requests and responses directly usually the subclasses L or L will be used instead. =head1 EXAMPLES # create packet from string my $invite = Net::SIP::Packet->new( <<'EOS' ); INVITE sip:you@example.com SIP/2.0 From: To: ... EOS # show and manipulate some header print "callid=".$invite->get_header( 'call-id' )."\n"; print "route=".join( ",", $invite->get_header( 'route' ))."\n"; $invite->set_header( 'via' => [ $via1,$via2,.. ] ); # get resulting string representation print $invite->as_string; # create packet from parts my $resp = Net::SIP::Packet->new( 200, 'Ok', { to => '', from => '',.. } Net::SIP::SDP->new(...) ); # and get the packet as string print $resp->as_string; =head1 CONSTRUCTOR =over 4 =item new ( STRING | @PARTS | HASH ) This is the default constructor. Depending on the number of arguments branches into B or B or just creates the object directly from the given HASH. =item new_from_string ( STRING ) Interprets STRING as a SIP request or response and creates L or L object accordingly (these classes must have been loaded already). Will die() if it cannot parse the string as a SIP packet. =item new_from_parts ( CODE|METHOD, TEXT|URI, \%HEADER|\@HEADER, [ BODY ] ) If CODE|METHOD is numeric a L object will be created with the response code CODE and the text TEXT. Otherwise a L object will be created with the method METHOD and the uri URI. Note that the Request or Response class need to be loaded already. Header data can be given as a hash %HEADER or array @HEADER reference. In case of a hash the key is the SIP field name and the value as either a string or a \@list of strings. The fields on the resulting SIP packet will be sorted by name of the fields and fields with multiple values will be created as seperat lines. If the header is given as an array the elements of the array are C<< [ key => value ] >> pairs where the keys are the field names and the values are strings or \@list of strings. Each pair will result in a single line in the SIP header. If the value was a list reference the values in the list will be concatened by ','. The order of the fields in the resulting SIP packet will be the same as in the array. The BODY is optional and can be given either as a string or as an reference to an object which has a method B, like L. If the BODY is an object which has a method B it will set the C header of the SIP object based on the result of C<< BODY->content_type >> unless a C header was explicitly given. =item _new_request | _new_response These work like C but assign the new object to the subclasses C resp. C. They are not intended to be used directly but only for redefining for using different subclasses when subclassing C. =back =head1 METHODS =over 4 =item is_request Returns TRUE if the SIP packet is a request, otherwise FALSE. =item is_response Returns TRUE if the SIP packet is a response, otherwise FALSE. =item tid Returns a transaction ID created from the sequence number in the C header and the C header. All packets with the same tid belong to the same transaction. =item cseq Returns C header. Short for C<< $self->get_header( 'cseq' ) >>. =item callid Returns C header. Short for C<< $self->get_header( 'call-id' ) >>. =item get_header ( [ NAME ] ) If NAME is given it returns the SIP header for NAME. If no header exists returns (). If there is only one value for the header returns this value. In case of multiple values it returns a @list of all values, but if C says, that the caller expects only a single value it will C. If no NAME is given it will return a reference to a hash which contains all fields and has the format described in B. =item add_header ( NAME, VAL ) Adds the header at the end of the SIP header. VAL can be a string or a reference to a list of strings. =item insert_header ( NAME, VAL ) Like B, but the lines will be added on top of the header. =item del_header ( NAME ) Delete all lines from header where the field name is NAME. =item set_header ( NAME, VAL ) Replaces an existing header, like B followed by B. =item set_body ( VAL ) Sets body to VAL, which can be string or object. The handling for body objects see B. =item as_string Returns string representation of SIP packet. =item dump ( [ LEVEL ] ) Returns dump of packet as string for debugging. The higher LEVEL is the more details one gets. At the moment a LEVEL of 0 gets a one-line summary and the rest the result from B. =item as_parts Returns Array with CODE|METHOD, TEXT|URI, \@HEADER and BODY like used in B. =item sdp_body Returns body as L object if there is a body and the content-type is 'application/sdp' or empty. If body contains invalid SDP it raises an exception (e.g. die()). =back =head2 UNDOCUMENTED METHODS =over 4 =item get_header_hashval ( [ NAME ] ) =item scan_header ( @ARG ) =item clone =back Net-SIP-0.822/lib/Net/SIP/Dispatcher.pod0000644000175100017510000002163213016115054016155 0ustar workwork =head1 NAME Net::SIP::Dispatcher - dispatch SIP packets between legs and endpoint =head1 SYNOPSIS my $disp = Net::SIP::Dispatcher->new( ... ); $disp->deliver( $request ); =head1 DESCRIPTION This module dispatches Ls between Ls and endpoints like L, L and L. It manages retransmission of outgoing packets and redelivery of responses to incoming requests. It is asssociated with an event handling like L. =head1 CONSTRUCTOR =over 4 =item new ( \@LEGS, EVENTLOOP, %ARGS ) Creates a new dispatcher object. @LEGS is a list of legs or specification for legs. See B for possible formats. EVENTLOOP is a eventloop which provides handling of events on file descriptors and timers. If not given a new L object will be created and used. See there how to define your own event loop package. %ARGS are parameters for the behavior of the dispatcher: =over 8 =item outgoing_proxy Specifies C<< "ip:port" >> of outgoing proxy, e.g the proxy which will be used for all outgoing packets. A leg to reach this proxy need to exist. =item do_retransmits If TRUE retransmits will be done according to RFC3261. If FALSE no retransmits will be done, which is used in the case of stateless proxies. Defaults to TRUE. This is the default for the delivery and can be overwritten in sub B. =item domain2proxy Optional mapping between target SIP domain and proxy to use. This is usually a hash of C<< ( domain, "ip_proxy:port_proxy" ) >> pairs. Special domain '*' can be used to specify a fallback and '*.domain' to include not only the domain but the subdomains too. See sub B for more details. =item dnsresolv Optional function to be used for DNS resolving instead of Net::DNS. This is intended for testing or for interfacing with own resolver code. The function is called with C<< (type,name,callback) >> and is expected to invoke the callback with the answer. C can be SRV, A or AAAA and the answer is expected to be a list consisting of C<< ['SRV',prio,host,port] >>, C<< ['A',ip,host] >> and C<< ['AAAA',ip,host] >>. =back The constructor will create a timer using the eventloop which will regularly (each second) call B. =back =head1 METHODS =over 4 =item set_receiver ( ENDPOINT ) This sets ENDPOINT as a receiver for incoming packets. ENDPOINT is an object with a method B or a callback usable by B in L. =item add_leg ( LEG ) Adds LEG as a leg to the dispatcher C<$self>. LEG can be either a L object, a L or a hash reference which is usable in the constructor of L. The leg will be added to the dispatchers eventloop for receiving incoming packets. =item remove_leg ( LEG ) Removes L object LEG from the dispatcher. =item get_legs ( %ARGS ) Get a list of all L objects matching the criteria given by %ARGS. %ARGS can be a combination of: =over 8 =item addr Matches if given address matches the legs source address. =item port Matches if given port matches the legs source port. =item proto Matches if given proto ('udp','tcp') matches the legs protocol. =item sub Call given sub with the L as argument. Matches if the sub returns TRUE. =back The leg matches %ARGS if the all conditions specified in %ARGS match. =item add_timer ( WHEN, CALLBACK, [ REPEAT ] ) Adds a timer using the eventloop. WHEN is either an absolute or a relative time (what it is will be decided based on the value of WHEN). Absolute times will be specified in time_t (seconds since 1970-01-01 00:00:00) and relative time will be specified in seconds. WHEN can be floating point to specify subseconds. WHEN can be C<0> to trigger the timer immediately. CALLBACK is a callback usable by B in L. REPEAT is the optional repeat interval for the timer. =item deliver ( PACKET, %ARGS ) Delivers B PACKET. %ARGS can specify hints for delivery: =over 8 =item id ID for packet, used in B. If not given the transaction ID of PACKET given by method B will be used. =item callid Call-ID for packet, used in B to cancel all deliveries for a specific call. If not given the Call-Id of PACKET given by method B will be used. =item callback callback which will be called on definite delivery of packet (only possible for TCP) or on definite failure. Callback will be invoked using B from B with the additional argument of C<$!>. See sub B in L. =item leg Specifies outgoing L object. For responses created by the endpoint the outgoing leg is usually known, because it's the same as the incoming leg for the request. =item dst_addr Destination, i.e. where to deliver the packet. This should be given as a hash with the keys C (udp|tcp|tls), C, C, C and C. This is necessary for responses, for requests it can be found out based on the requests URI. =item do_retransmits Specifies if retransmits should be done according to RFC3261. This is usually the case, except for stateless proxies. Overwrites the global parameter with the same name from the constructor for the delivery of the specific packet. =back Delivery of the packet itself will be handled in multiple steps (in the code done mainly by sub B<__deliver>: =over 8 =item * If a leg is specified it will be used for delivery. B needs to be specified in this case too. This is usually the case for locally generated responses. =item * Otherwise leg and dst_addr will be retrieved using B. See there. =back If the packets could be retransmitted appropriate setups will be done. Retransmission will be done until final failure or until B will be called for the packet, which usually means, that the packet was successfully delivered because a response to the packet was received. =item resolve_uri ( URI, ADDR, LEGS, CALLBACK, [ ALLOWED_PROTO, ALLOWED_LEGS ] ) Resolves URI to get the destination address and the outgoing leg. ADDR and LEGS are references to lists which will get filled with the computed values. If ALLOWED_PROTO is given it will be interpreted as a \@list of protocols. Only the protocols given in the list will be considered and the it will try them in the order from the list, e.g. C<< ('tcp','udp') >> means that tcp is tried first and only if there is no way to do tcp it will try udp. Default is to first try udp and then tcp. If ALLOWED_LEGS is given it will be interpreted as a \@list of L objects and only these legs are allowed. Because the method can be asynchronous (DNS lookups can be involved) it will call CALLBACK once it is done. If no errors occurred CALLBACK will be invoked without additional arguments, otherwise with the errno as additional argument. Resolving will be done as follows: =over 8 =item * If B is given it will try to get the dst_addr from this, e.g. the address of the proxy responsable for the domain (if any). From dst_addr it will then get the leg. =item * If still no dst_addr is known it will use B as the dst_addr. =item * If still no dst_addr is known but the SIP domain is an IP address this will be used as dst_addr. =item * The last effort will be made by looking up the SIP domain using DNS with a partial implementation of RFC3263, e.g. it looks at the DNS SRV records but not at NAPTR records. =item * For each destination address (e.g. proto,addr,port) the outgoing leg will be computed. This will be done in sub B<__find_leg4addr> by going through all legs and checking, if the leg could deliver to this address by calling B on the leg (see L). =back =item cancel_delivery ( TYP?,ID ) Cancels retransmission of packet with id ID. Called from endpoint if response to packet came in, which means that the packet was successfully delivered. If TYP given packets can be canceled by something else. TYP can be C, in which case all deliveries for a specific call will be canceled. It can be C which will cancel the packet with id ID. Or it can be C in which case ID will be interpreted as the L object in the queue and it will cancel this packet. Will return true if the item was canceled, false if no such item was found in delivery queue. =item receive ( PACKET, LEG, FROM ) Called from the eventloop (e.g was setup as a callback) for incoming packets. The new L is PACKET, LEG is the L where the packet came in and FROM is C<< "ip:port" >> of the sender. =item queue_expire ( [ NOW ] ) Expires retransmission queue, e.g. deletes packet where retransmissions failed permanently (and calls appropriate callbacks) and initiates pending retransmissions. Called from a timer setup in the constructor. =back Net-SIP-0.822/lib/Net/SIP/DTMF.pm0000644000175100017510000003250613142324425014461 0ustar workwork########################################################################### # Net::SIP::DTMF # implements DTMF handling (audio and rfc2833) ########################################################################### use strict; use warnings; package Net::SIP::DTMF; use base 'Exporter'; our @EXPORT = qw(dtmf_generator dtmf_extractor); use Net::SIP::Debug; use Time::HiRes 'gettimeofday'; use Carp 'croak'; ########################################################################### # sub dtmf_generator returns a sub, which is used to generate RTP packet # for DTMF events # Args: ($event,$duration,%args) # $event: DTMF event ([0-9A-D*#]), anything else will be pause # $duration: duration in ms # %args: # rfc2833_type => $rtptype: if defined will generate RFC2833 RTP events # audio_type => $rtptype: if defined will generate audio # volume => volume for rfc2833 events (default 10) # Returns: $sub # $sub: sub which returns @rtp_packets when called with # $sub->($seq,$timestamp,$srcid) # if $sub returns () the DTMF event is finished (>duration) # if $sub returns ('') no data are produced (pause between events) # usually sub will return just one packet, but for RTP event ends it # will return 3 to make sure that at least one gets received # ########################################################################### sub dtmf_generator { my ($event,$duration,%pargs) = @_; # empty or invalid stuff will cause pause/silence $event = '' if ! defined $event or $event !~ m{[\dA-D\*\#]}i; if ( defined( my $type = $pargs{rfc2833_type} )) { # create RFC2833 payload return _dtmf_gen_rtpevent($event,$type,$duration,%pargs); } elsif ( defined($type = $pargs{audio_type})) { # create audio payload return _dtmf_gen_audio($event,$type,$duration,%pargs); } else { croak "neither rfc2833 nor audio RTP type defined" } } ########################################################################### # sub dtmf_extractor creates sub to extract DTMF from RTP # Args: (%pargs) # %pargs: rfc2833_type, audio_type like in dtmf_generator # will try to extract DTMF from RTP packets for any type set, e.g. # RFC2833 and audio can be done in parallel # Returns: $sub # $sub: should be called with ($packet,[$time]), if $time not # given current time will be used. The $sub itself will return () if no # event (end) was found and ($event,$duration,$type) if event was detected. # $event is [0-9A-D*#], $type rfc2833|audio # Comment: FIXME - maybe disable audio detection if a rfc2833 event was # received. In this case the peer obviously uses rfc2833 ########################################################################### sub dtmf_extractor { my %pargs = @_; my %sub; if ( defined( my $type = delete $pargs{rfc2833_type} )) { # extract from RFC2833 payload $sub{$type} = _dtmf_xtc_rtpevent(%pargs); } if ( defined( my $type = delete $pargs{audio_type})) { # extract from audio payload $sub{$type} = _dtmf_xtc_audio(%pargs); } croak "neither rfc2833 nor audio RTP type defined" if ! %sub; my $lastseq; return sub { my ($pkt,$time) = @_; my ($ver,$type,$seq,$tstamp,$srcid,$payload) = unpack('CCnNNa*',$pkt); $ver == 0b10000000 or return; my $marker; if ($type & 0b10000000) { $marker = 1; $type &= 0b01111111; } my $seqdiff; if (defined $lastseq) { $seqdiff = (2**16 + $seq - $lastseq) & 0xffff; if (!$seqdiff) { $DEBUG && DEBUG(20,"dropping duplicate RTP"); return; } elsif ($seqdiff>2**15) { $DEBUG && DEBUG(20,"dropping out of order RTP"); return; } else { $DEBUG && $seqdiff>1 && DEBUG(30,'lost %d packets (%d-%d)', $seqdiff-1,$lastseq+1,$seq-1); } } $lastseq = $seq; my $sub = $sub{$type} or return; my ($event,$duration,$media) = $sub->($payload,$time,$marker,$seqdiff) or return; return ($event, int(1000*$duration),$media); }; } ########################################################################### # END OF PUBLIC INTERFACE ########################################################################### ########################################################################### # # RTP DTMF events # ########################################################################### # mapping between event string and integer for RTP events my %event2i; { my $i=0; %event2i = map { $_ => $i++ } split('','0123456789*#ABCD'); } my %i2event = reverse %event2i; ########################################################################### # generate DTMF RTP events according to rfc2833 # Args: $event,$duration,%args # %args: volume => v will be used to set volume of RTP event, default 10 # Returns: $sub for $event # Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid) # This will generate the RTP packet. # If $event is no DTMF event it will return '' to indicate pause ########################################################################### sub _dtmf_gen_rtpevent { my ($event,$type,$duration,%args) = @_; my $volume = $args{volume} || 10; $duration/=1000; # ms ->s my $start = gettimeofday(); my $end = 0; my $first = 1; my $initial_timestamp; return sub { my ($seq,$timestamp,$srcid) = @_; # all packets get timestamp from start of event if ( ! $initial_timestamp ) { $initial_timestamp = $timestamp; return ''; # need another call to get duration } if ( gettimeofday() - $start > $duration ) { return if $end; # end already sent $end = 1; } return '' if $event eq ''; my $pt = $type; if ( $first ) { $first = 0; $pt |= 0b10000000; # marker bit set on first packet of event } return pack('CCnNNCCn', 0b10000000, $pt, $seq, $initial_timestamp, $srcid, $event2i{$event}, ($end<<7) | $volume, $timestamp > $initial_timestamp ? $timestamp - $initial_timestamp : 0x10000 - $initial_timestamp + $timestamp, ); } } ########################################################################### # returns sub to extract DTMF events from RTP telephone-event/8000 payload # Args: NONE # Returns: $sub # $sub - will be called with ($rtp_payload,[$time],$marker) # will return ($event,$duration) if DTMF event was found ########################################################################### sub _dtmf_xtc_rtpevent { my $current_event; return sub { my ($payload,$time,$marker) = @_; my ($event,$volume,$duration) = unpack('CCn',$payload); $event = $i2event{$event}; my $end; if ( $volume & 0b10000000 ) { $end = 1; $volume &= 0b01111111 } if ( ! $current_event ) { return if $end; # probably repeated send of end # we don't look at the marker for initial packet, because maybe # the initial packet got lost $current_event = [ $event,$time||gettimeofday(),$volume ]; } elsif ( $event eq $current_event->[0] ) { if ( $end ) { # explicit end of event my $ce = $current_event; $current_event = undef; $time ||= gettimeofday(); return ($ce->[0],$time - $ce->[1],'rfc2833'); } } else { # implicit end because we got another event my $ce = $current_event; $time||= gettimeofday(); $current_event = [ $event,$time,$volume ]; return if ! $ce->[2]; # volume == 0 return ($ce->[0],$time - $ce->[1],'rfc2833'); } return; }; } ########################################################################### # # RTP DTMF audio # ########################################################################### # mapping between frequence and key for audio my @freq1 = (697,770,852,941); my @freq2 = (1209,1336,1477,1633); my @keys = '123A 456B 789C *0#D' =~m{(\S)}g; my (%event2f,@f2event); for( my $i=0;$i<@keys;$i++ ) { my $freq1 = $freq1[ $i/4 ]; my $freq2 = $freq2[ $i%4 ]; $event2f{$keys[$i]} = [$freq1,$freq2]; $f2event[$freq1][$freq2] = $keys[$i]; } # basic paramter, PCMU/8000 160 samples per RTP packet my $volume = 100; my $samples4s = 8000; my $samples4pkt = 160; use constant PI => 3.14159265358979323846; # tables for audio processing get computed on first use # cosinus is precomputed. How exakt a cos will be depends on # the size of the table $tabsize my $tabsize = 256; my @costab; # tables for PCMU u-law compression my @ulaw_expandtab; my @ulaw_compresstab; # Goertzel algorithm my $gzpkts = 3; # 3 RTP packets = 60ms my %coeff; my @blackman; # exact blackman # precompute stuff into tables for faster operation sub _init_audio_processing { # audio generation @costab and return; for(my $i=0;$i<$tabsize;$i++) { $costab[$i] = $volume/100*16383*cos(2*PI*$i/$tabsize); } # PCMU/8000 u-law (de)compression for( my $i=0;$i<128;$i++) { $ulaw_expandtab[$i] = int( (256**($i/127) - 1) / 255 * 32767 ); } my $j = 0; for( my $i=0;$i<32768;$i++ ) { $ulaw_compresstab[$i] = $j; $j++ if $j<127 and $ulaw_expandtab[$j+1] - $i < $i - $ulaw_expandtab[$j]; } for my $freq (@freq1,@freq2) { my $k = int(0.5+$samples4pkt*$freq/$samples4s); my $w = 2*PI/$samples4pkt*$k; $coeff{$freq} = 2*cos($w); } my $n = $samples4pkt*$gzpkts; for( my $i=0;$i<$n;$i++) { $blackman[$i] = 0.426591 - 0.496561*cos(2*PI*$i/$n) +0.076848*cos(4*PI*$i/$n) } } ########################################################################### # sub _dtmf_gen_audio returns a sub to generate audio/silence for DTMF in # any duration # Args: $event,$duration # Returns: $sub for $event # Comment: the sub should then be called with $sub->($seq,$timstamp,$srcid) # This will generate the RTP packet. # If $event is no DTMF event it will return a sub which gives silence. # Data returned from the subs are PCMU/8000, 160 samples per packet ########################################################################### sub _dtmf_gen_audio { my ($event,$type,$duration) = @_; $duration/=1000; # ms ->s my $start = gettimeofday(); my $f = $event2f{$event}; if ( ! $f ) { # generate silence return sub { my ($seq,$timestamp,$srcid) = @_; return if gettimeofday() - $start > $duration; # done return pack('CCnNNa*', 0b10000000, $type, $seq, $timestamp, $srcid, pack('C',128) x $samples4pkt, ); } } _init_audio_processing() if !@costab; my ($f1,$f2) = @$f; $f1*= $tabsize; $f2*= $tabsize; my $d1 = int($f1/$samples4s); my $d2 = int($f2/$samples4s); my $g1 = $f1 % $samples4s; my $g2 = $f2 % $samples4s; my $e1 = int($samples4s/2); my $e2 = int($samples4s/2); my $i1 = my $i2 = 0; return sub { my ($seq,$timestamp,$srcid) = @_; return if gettimeofday() - $start > $duration; # done my $samples = $samples4pkt; my $buf = ''; while ( $samples-- > 0 ) { my $val = $costab[$i1]+$costab[$i2]; my $c = $val>=0 ? 255-$ulaw_compresstab[$val] : 127-$ulaw_compresstab[-$val]; $buf .= pack('C',$c); $e1+= $samples4s, $i1++ if $e1<0; $i1 = ($i1+$d1) % $tabsize; $e1-= $g1; $e2+= $samples4s, $i2++ if $e2<0; $i2 = ($i2+$d2) % $tabsize; $e2-= $g2; } return pack('CCnNNa*', 0b10000000, $type, $seq, $timestamp, $srcid, $buf, ); } } ########################################################################### # returns sub to extract DTMF events from RTP PCMU/8000 payload # Args: NONE # Returns: $sub # $sub - will be called with ($rtp_payload,[$time]) # will return ($event,$duration) if DTMF event was found, event being 0..15 ########################################################################### sub _dtmf_xtc_audio { _init_audio_processing() if !@costab; my (%d1,%d2,@time,@lastev); return sub { my ($payload,$time) = @_; $time ||= gettimeofday(); my @samples = map { ( $_<128 ? -$ulaw_expandtab[127-$_] : $ulaw_expandtab[255-$_] )/32768 } unpack('C*',$payload); @samples == $samples4pkt or return; # unexpected sample size unshift @time, $time; for my $f (@freq1,@freq2) { my $coeff = $coeff{$f}; my $da1 = $d1{$f} ||= []; my $da2 = $d2{$f} ||= []; unshift @$da1,0; unshift @$da2,0; for(my $gzi=0;$gzi<@$da1;$gzi++) { my $d1 = $da1->[$gzi]; my $d2 = $da2->[$gzi]; my $o = $gzi*$samples4pkt; for( my $i=0;$i<@samples;$i++) { ($d2,$d1) = ($d1, $samples[$i]*$blackman[$i+$o] + $coeff*$d1 - $d2); } $da1->[$gzi] = $d1; $da2->[$gzi] = $d2; } } return if @time < $gzpkts; $time = pop @time; my @r; for my $f (@freq1,@freq2) { my $d1 = pop(@{$d1{$f}}); my $d2 = pop(@{$d2{$f}}); push @r, [ $f, $d1*$d1+$d2*$d2-$d1*$d2*$coeff{$f} ]; } # the highest two freq should be significantly higher then rest @r = sort { $b->[1] <=> $a->[1] } @r; # sort by magnitude, largest first my $event; if ( @r and ! $r[2][1] || $r[1][1]/$r[2][1]> 5 ) { $event = $f2event[ $r[0][0] ][ $r[1][0] ]; $event = $f2event[ $r[1][0] ][ $r[0][0] ] if ! defined $event; } $event = '' if ! defined $event; push @lastev,[$event,$time]; # remove pause from start of lastev shift(@lastev) while (@lastev && $lastev[0][0] eq ''); # if last event same as first wait for more if ( ! @lastev ) { # return; # no events detected } elsif ( $event eq $lastev[0][0] ) { return; # event not finished } else { my @ev = shift(@lastev); while (@lastev and $lastev[0][0] eq $ev[0][0]) { push @ev,shift(@lastev); } # get the event at least 2 times return if @ev == 1; return ($ev[0][0],$ev[-1][1]-$ev[0][1],'audio'); # event,duration } return; }; } 1; Net-SIP-0.822/lib/Net/SIP/Leg.pod0000644000175100017510000001335013016115054014574 0ustar workwork =head1 NAME Net::SIP::Leg - Wrapper around Socket for sending and receiving SIP packets =head1 SYNOPSIS my $leg = Net::SIP::Leg->new( addr => '192.168.0.2' ); $leg->deliver( $packet, '192.168.0.5:5060' ); =head1 DESCRIPTION A B wraps the socket which is used to send and receive packets. It provides ways to strip B header from incoming packets, to add B header to outgoing packets and to add B header while forwarding. It's usually not used directly, but from L. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) The constructor creates a new object based on the hash %ARGS. The following keys are used from %ARGS: =over 8 =item sock The socket as IO::Socket object. C, C, C and C will be determined from this object and not from %ARGS. This will be used to create the B object. =item socketpool The socketpool as L compatible object. This argument can not be used together with C. It will instead determine the master socket by calling B on the given B object. =item addr The local IP address of the socket. If this is given but no port it will extract port from addr, if it's in the format C<< host:port >>. =item host The hostname matching C. This is used to create default contact information and the Via header. If not given defaults to the IP address. Use of hostname instead of IP address is relevant for TLS where the name is needed in validation of the peers certificate. =item port The port of the socket. Defaults to 5060. =item family The family of the socket. Will be determined from C if omitted. =item proto The connection protocol, e.g. 'udp', 'tcp' or 'tls'. Defaults to 'udp'. =item dst The optional fixed target of the leg as hash with keys C, C, C and C. =item contact Optional contact information which will be added as B header to outgoing requests and used within Contact header for 200 Responses to INVITE. If not given it will be created based on C, C and C. =item tls Optional arguments to be used in creating a TLS connection, as expected by L. These are used for both incoming and outgoing TLS connection. Typically this involves C, C and C or similar. =back If no socket is given with C it will be created based on C, C and C. If this fails the constructur will C<< die() >>. The constructor will create a uniq branch tag for this leg. =back =head1 METHODS =over 4 =item forward_incoming ( PACKET ) Modifies the L PACKET in-place for forwarding, e.g strips top B header in responses, adds B parameter to top B header in requests, handles the difference between forwarding of requests to strict or loose routes and inserts B header in requests. =item forward_outgoing ( PACKET, LEG_IN ) Similar to B, but will be called on the outgoing leg. LEG_IN is the L, where the packet came in (and where B was called). Will add B header and remove itself from B. =item deliver ( PACKET, ADDR, [ CALLBACK ] ) Delivers L PACKET through the leg C<$self> to ADDR. ADDR is a hash with the keys C, C, C and C. Usually this method will be call from within L. If the packet was received by the other end (which is only possible to say if a reliable protocol, e.g. 'tcp' was used) it will call CALLBACK if provided. See B in L for the format of callbacks. If the packet could not be delivered CALLBACK will be invoked with the appropriate errno (C<$!>). While delivering requests it adds a B header. =item receive(PACKET, FROM) This is called from the dispatcher if the the L B was received from B. FROM is given as hash with keys C, C, C and C. This function might process the packet further or block it. It will return C<< (PACKET, FROM) >> in the normal case or C<()> if blocked. =item check_via ( PACKET ) Returns TRUE if the top B header in the L PACKET contains the B-tag from C<$self>, otherwise FALSE. Used to check if the response came in through the same leg the response was send. =item add_via ( PACKET ) Adds itself to PACKET as B header. =item can_deliver_to ( ADDR|%SPEC ) Returns TRUE if the leg can deliver address specified by ADDR or %SPEC. ADDR is a full or partial SIP URI. If the caller has 'proto','addr','port' and 'family' already as separate items it can call the method with %SPEC instead. Right now it has now way to check if the leg can deliver to a specific host because it has no access to the routing information of the underlying OS, so that only proto will be checked. =item match(%SPEC) This checks if the given B matches the leg. This is used from inside the B in L to get all legs matching specific criteria. The B can contain the keys C, C and C which match the arguments given during construction of the leg or are obtained from the legs socket. Additionally C can be used to specify a function which gets called with the leg object and must return true on match only. The method returns true if there was a full match and false otherwise. =item socketpool This returns the L object associated with the leg. =item laddr(LEVEL) This will return the local address of the socket, either as address only (B is 0) or as C (higher levels). =item dump Returns string containing information about the leg. Used for debugging. =back Net-SIP-0.822/lib/Net/SIP/Response.pm0000644000175100017510000000232712271422677015535 0ustar workwork########################################################################### # package Net::SIP::Response # subclass from Net::SIP::Packet for managing the response packets ########################################################################### use strict; use warnings; package Net::SIP::Response; use base 'Net::SIP::Packet'; ########################################################################### # Redefine methods from Net::SIP::Packet, no need to find out dynamically ########################################################################### sub is_request {0} sub is_response {1} ########################################################################### # Accessors for numerical code and text # (e.g. "407 Authorization required" ) ########################################################################### sub code { return (shift->as_parts())[0] } sub msg { return (shift->as_parts())[1] } ########################################################################### # get method of original request by parsing CSeq header ########################################################################### sub method { my $cseq = shift->cseq || return; return $cseq =~m{\d+\s+(\w+)} && $1; } 1; Net-SIP-0.822/lib/Net/SIP/Endpoint.pod0000644000175100017510000001640013016115241015642 0ustar workwork =head1 NAME Net::SIP::Endpoint - Endpoint for SIP packets (UAC,UAS) =head1 SYNOPSIS my $disp = Net::SIP::Dispatcher->new(...); my $ua = Net::SIP::Endpoint->new($disp); $ua->register( from => 'sip:me@example.com', contact => 'sip:me@192.168.0.1', registrar => 'sip:192.168.0.10:5060' ); =head1 DESCRIPTION The package implements a communication endpoint for SIP. This is usually a phone, but can also be a stateful proxy (because it retransmits packets itself). It provides methods to send arbitrary requests but also for sending special requests like INVITE or REGISTER. Together with L it implements the behavior of the endpoint. For incoming requests the endpoint usually communicates with the upper layer, the application, which is the interface to the user (e.g. let it ring for incoming calls, create response for call accepted if user picks up phone on incoming call etc). =head1 CONSTRUCTOR =over 4 =item new ( DISPATCHER ) Creates a new endpoint and sets it as the receiver for incoming packets at the L DISPATCHER. The endpoint will use DISPATCHER for outgoing packets and will receive incoming packets from it. =back =head1 METHODS =over 4 =item set_application ( APP ) Sets APP as the upper layer, e.g. the layer between the user and the endpoint object C<$self>. APP is either an object which has a method B or a callback usable by B in L. The callback will be invoked with the following arguments: =over 8 =item ENDPOINT This is the endpoint itself, e.g. C<$self>. =item CTX The L object for the current call. =item REQUEST The L which caused the invocation of the call, e.g. an INVITE on new calls, ACK if the peer established the call, BYE if a call gets closed by the peer etc. =item LEG The L object where the call came in. Together with FROM used to send response packet back to peer. =item FROM Hash with information about the sender of the request (keys C, C, C, C and C) =back It will call into APP in various incoming requests, like: =over 8 =item INVITE In this case APP should ring the user and while ringing send C<< 180 Ringing >> responses back to the peer, using C<< ENDPOINT->new_response >>. After some time it should send a final response (like C<< 200 Ok >> if the user accepted the call). =item ACK This is the sign, that the peer established the call. APP should now expect to process incoming RTP data and send RTP data itself. =item CANCEL, BYE This informs APP, that the call is closed. No need for the APP to send a response itself, this was already handled by the endpoint (because there is no choice of responses, it can hardly not accept a BYE). =item other requests Like OPTION,.. . Theseneed to be fully handled by APP, e.g. send the appropriate response back using C<< ENDPOINT->new_response >>. =back =item invite ( CTX, [ CALLBACK, BODY, %ARGS ] ) Creates a new INVITE request and delivers it to the peer. Simply calls B with the method 'INVITE'. See this method for information for the arguments. =item register ( %ARGS ) Registers endpoint at remote registrar. %ARGS needs to be filled as follows: =over 8 =item registrar SIP URI of registrar, i.e. anything acceptable to B from L. Mandatory. =item from The address to register at the registrar. Mandatory. =item contact The contact, under which C will be registered. Mandatory. =item auth Authorization info, see method B in L for information about the format. Optional. =item expires Expires time. Optional, defaults to 900. =item callback Optional callback, e.g. called if requests come in from the peer on the call created for the registration. See B in L for the format. =back All other keys will be used as header keys in generating the L object. =item new_request ( METHOD, CTX, [ CALLBACK, BODY, %ARGS ] ) Method is the uppercase name of the method for which a request should be generated. It can also be already a L object in which case no new request object will be generated, but the provided delivered. CTX is either an existing L object or a hash reference which will be used to construct one. It contains information about C and C etc. See constructor in L for details. In case of a hash reference B and B from ARGS will be used for the newly constructed context. If it is an existing CTX it has to be one which is already managed by this endpoint (e.g. one returned by this method), the endpoint will only manage CTX which it created itself so that a context cannot be shared between multiple endpoints. CALLBACK is a callback usable by B in L. If defined it will be set up as the new default callback for the context. BODY is a string or an object for the SIP body accepted by the constructor of L. See there. If a response object is given as B in ARGS it will be used to authorize the newly created request. Anything else in %ARGS will be used to construct the SIP header. See constructor in L. It returns the L object for this request which can be then used for further requests in the same call. =item cancel_invite ( CTX, REQUEST, CALLBACK ) Cancel the given request within the given context (e.g send CANCEL request). If no REQUEST is given it will cancel the most recent INVITE. Returns the number of requests canceled, e.g. 0 or 1. CALLBACK will be used as the callback for the CANCEL request it sends using B. =item close_context ( CTX ) Delete L object CTX from the list of active calls. =item receive ( PACKET, LEG, FROM ) Called from dispatcher on incoming packets. PACKET is the incoming L, LEG the L where the packet came in and FROM the hash with the sender info. Just forwards to B or B based on the type of packet. =item receive_response ( RESPONSE, LEG, FROM ) Handles incoming response packets. Tries to find an active call based on the C header in the packet. If none was found it will drop the packet, otherwise call B on the call context object (L). =item receive_request ( REQUEST, LEG, FROM ) Handles incoming requests. If there is already a call context for this B in the request it will use it, otherwise it will create a L object based on the information in the request (C, C, C,... ). Calls B on the existing/new context object. =item new_response ( CTX, RESPONSE, LEG, ADDR ) Delivers L packet RESPONSE through the endpoints dispatcher to ADDR (hash) using L LEG. LEG and ADDR are usually the leg and the senders address where the associated request came in. CTX is the context from the call, where the associated request came in. If the response is a 2xx response to a INVITE and no C header is given as required from the RFC it will add one based on the CTX. =back Net-SIP-0.822/lib/Net/SIP/Leg.pm0000644000175100017510000005411713535436774014461 0ustar workwork########################################################################### # 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; Net-SIP-0.822/lib/Net/SIP/SDP.pm0000644000175100017510000003434113370543213014355 0ustar workwork########################################################################### # Net::SIP::SDP # parse and manipulation of SDP packets in the context relevant for SIP # Spec: # RFC2327 - base RFC for SDP # RFC3264 - offer/answer model with SDP (used in SIP RFC3261) # RFC3266 - IP6 in SDP # RFC3605 - "a=rtcp:port" attribute UNSUPPORTED!!!! ########################################################################### use strict; use warnings; package Net::SIP::SDP; use Hash::Util qw(lock_keys); use Net::SIP::Debug; use Net::SIP::Util qw(ip_is_v4 ip_is_v6); use Socket; use Scalar::Util 'looks_like_number'; ########################################################################### # create new Net::SIP::SDP packet from string or parts # Args: see new_from_parts|new_from_string # Returns: $self ########################################################################### sub new { my $class = shift; return $class->new_from_parts(@_) if @_>1; my $data = shift; return ( !ref($data) || UNIVERSAL::isa( $data,'ARRAY' )) ? $class->new_from_string( $data ) : $class->new_from_parts( $data ); } ########################################################################### # create new Net::SIP::SDP packet from parts # Args: ($class,$global,@media) # $global: \%hash of (key,val) for global section, val can be # scalar or array-ref (for multiple val). keys can be the # on-letter SDP keys and the special key 'addr' for constructing # a connection-field # @media: list of \%hashes. val in hash can be scalar or array-ref # (for multiple val), keys can be on-letter SDP keys or the special # keys addr (for connection-field), port,range,proto,media,fmt (for # media description) # Returns: $self ########################################################################### sub new_from_parts { my ($class,$global,@media) = @_; my %g = %$global; my $g_addr = delete $g{addr}; die "no support for time rates" if $g{r}; my $atyp; if ($g_addr && !$g{c}) { $atyp = ip_is_v4($g_addr) ? 'IP4':'IP6'; $g{c} = "IN $atyp $g_addr"; } $g{t} = "0 0" if !$g{t}; my @gl; my %global_self = ( lines => \@gl, addr => $g_addr ); lock_keys(%global_self); my @media_self; my $self = bless { global => \%global_self, addr => $g_addr, media => \@media_self },$class; lock_keys(%$self); # first comes the version push @gl,[ 'v',delete($g{v}) || 0 ]; # then the origin my $o = delete($g{o}); if ( !$o ) { my $t = time(); $atyp ||= $g{c} =~m{^IN (IP4|IP6) } && $1; $o = "anonymous $t $t IN $atyp ".( $g_addr || ($atyp eq 'IP4' ? '127.0.0.1' : '::1') ); } push @gl,[ 'o',$o ]; # session name push @gl,[ 's', delete($g{s}) || 'session' ]; # various headers in the right order foreach my $key (qw( i u e p c b t z k a )) { my $v = delete $g{$key}; defined($v) || next; foreach ( ref($v) ? @$v:($v) ) { push @gl, [ $key,$_ ]; } } # die on unknown keys die "bad keys in global: ".join( ' ',keys(%g)) if %g; # media descriptions foreach my $m (@media) { DEBUG_DUMP( 100,$m ); my %m = %$m; delete $m{lines}; my @lines; my %m_self = ( lines => \@lines ); # extract from 'm' line or from other args if ( my $mline = delete $m{m} ) { push @lines,[ 'm',$mline ]; @m_self{qw(media port range proto fmt)} = _split_m( $mline ); } else { foreach (qw( port media proto )) { defined( $m_self{$_} = delete $m{$_} ) || die "no $_ in media description"; } $m_self{range} = delete($m{range}) || ( $m_self{proto} =~m{^RTP/} ? 2:1 ); defined( my $fmt = $m_self{fmt} = delete $m{fmt} ) || die "no fmt in media description"; my $mline = _join_m( @m_self{qw(media port range proto)},$fmt ); push @lines, [ 'm',$mline ]; } # if no connection line given construct one, if addr ne g_addr if ( !$m{c} ) { if ( my $addr = delete $m{addr} ) { $m_self{addr} = $addr; $m{c} = _join_c($addr) if $addr ne $g_addr; } elsif ( $g_addr ) { $m_self{addr} = $g_addr; } else { die "neither local nor global address for media"; } } else { $m_self{addr} = _split_c($m{c}); } # various headers in the right order foreach my $key (qw( i c b k a )) { my $v = delete $m{$key}; defined($v) || next; foreach ( ref($v) ? @$v:($v) ) { push @lines, [ $key,$_ ]; } } # die on unknown keys die "bad keys in media: ".join( ' ',keys(%m)) if %m; lock_keys(%m_self); push @media_self,\%m_self; } return $self; } ########################################################################### # create new Net::SIP::SDP packet from string or lines # Args: ($class,$string) # $string: either scalar or \@list_of_lines_in_string # Returns: $self ########################################################################### sub new_from_string { my ($class,$string) = @_; # split into lines Carp::confess('expected string or ARRAY ref' ) if ref($string) && ref( $string ) ne 'ARRAY'; my @lines = ref($string) ? @$string : split( m{\r?\n}, $string ); # split lines into key,val foreach my $l (@lines) { my ($key,$val) = $l=~m{^([a-z])=(.*)} or die "bad SDP line '$l'"; $l = [ $key,$val ]; } # SELF: # global { # lines => [], # addr # globally defined addr (if any) # } # media [ # { # lines => [], # addr # addr for ports # port # starting port # range # range of ports (1..) # proto # udp, RTP/AVP,.. # media # audio|video|data... # } # ] my (%global,@media); my $self = bless { global => \%global, addr => undef, session_id => undef, session_version => undef, media => \@media }, $class; lock_keys(%$self); my $gl = $global{lines} = []; # first line must be version my $line = shift(@lines); $line->[0] eq 'v' || die "missing version"; $line->[1] eq '0' || die "bad SDP version $line->[1]"; push @$gl,$line; # second line must be origin # "o=" username sess-id sess-version nettype addrtype addr $line = shift(@lines); $line->[0] eq 'o' || die "missing origin"; (undef,$self->{session_id},$self->{session_version}) = split( ' ',$line->[1] ); push @$gl,$line; # skip until c or m line my $have_c =0; while ( $line = shift(@lines) ) { # end of global section, beginning of media section last if $line->[0] eq 'm'; push @$gl,$line; if ( $line->[0] eq 'c' ) { # "c=" nettype addrtype connection-address $have_c++ && die "multiple global [c]onnection fields"; $global{addr} = _split_c( $line->[1] ); } } # parse media section(s) # $line has already first m-Element in it while ($line) { $line->[0] eq 'm' || die "expected [m]edia line"; # "m=" media port ["/" integer] proto 1*fmt my ($media,$port,$range,$proto,$fmt) = _split_m( $line->[1] ); my $ml = [ $line ]; my %m = ( lines => $ml, addr => $global{addr}, port => $port, range => $range || 1, media => $media, proto => $proto, fmt => $fmt, ); lock_keys(%m); push @media,\%m; # find out connection my $have_c = 0; while ( $line = shift(@lines) ) { # next media section last if $line->[0] eq 'm'; push @$ml,$line; if ( $line->[0] eq 'c' ) { # connection-field $have_c++ && die "multiple [c]onnection fields in media section $#media"; $m{addr} = _split_c( $line->[1] ); } } } return $self; } ########################################################################### # get SDP data as string # Args: $self # Returns: $string ########################################################################### sub as_string { my $self = shift; my $data = ''; foreach (@{ $self->{global}{lines}} ) { $data .= $_->[0].'='.$_->[1]."\r\n"; } if ( my $media = $self->{media} ) { foreach my $m (@$media) { foreach (@{ $m->{lines} }) { $data .= $_->[0].'='.$_->[1]."\r\n"; } } } return $data; } sub content_type { return 'application/sdp' }; ########################################################################### # extracts media infos # Args: $self # Returns: @media|$media # @media: list of hashes with the following keys: # addr: IP4/IP6 addr # port: the starting port number # range: number, how many ports starting with port should be allocated # proto: media proto, e.g. udp or RTP/AVP # media: audio|video|data|... from the media description # fmt: format(s) from media line # lines: \@list with all lines from media description as [ key,value ] # useful to access [a]ttributes or encryption [k]eys # $media: \@media if in scalar context # Comment: do not manipulate the result!!! ########################################################################### sub get_media { my $self = shift; my $m = $self->{media} || []; return wantarray ? @$m : $m; } ########################################################################### # returns type number to RTP codec name, e.g. 'telephone-event/8000' -> 101 # Args: ($self,$name,[$index]) # $name: name of codec # $index: index or type of media description, default 0, e.g. the first # channel. 'audio' would specify the first audio channel # Returns: type number|undef ########################################################################### sub name2int { my ($self,$name,$index) = @_; $index = 0 if ! defined $index; my $m = $self->{media}; if ( ! looks_like_number($index)) { # look for media type my @i = grep { $m->[$_]{media} eq $index } (0..$#$m) or return; $index = $i[0]; } $m = $m->[$index] or return; for my $l (@{$m->{lines}}) { $l->[0] eq 'a' or next; $l->[1] =~m{^rtpmap:(\d+)\s+(\S+)} or next; return $1 if $2 eq $name; } return; } ########################################################################### # replace the addr and port (eg where it will listen) from the media in # the SDP packet # used for remapping by a proxy for NAT or inspection etc. # Args: ($self,@replace) # @replace: @list of [ addr,port ] or list with single array-ref to such list # size of list must be the same like one gets from get_media, e.g. # there must be a mapping for each media # Comment: die() on error ########################################################################### sub replace_media_listen { my ($self,@replace) = @_; if (@replace == 1) { # check if [ $pair1,$pair2,.. ] instead of ( $pair1,.. ) @replace = @{$replace[0]} if ref($replace[0][0]); } my $media = $self->{media} || []; die "media count mismatch in replace_media_listen" if @replace != @$media; my $global = $self->{global}; my $g_addr = $global->{addr}; # try to remap global connection-field if ( $g_addr ) { # find mappings old -> new my %addr_old2new; for( my $i=0;$i<@$media;$i++ ) { $addr_old2new{ $media->[$i]{addr} }{ $replace[$i][0] }++ } my $h = $addr_old2new{ $g_addr }; if ( $h && keys(%$h) == 1 ) { # there is a uniq mapping from old to new address my $new_addr = (keys(%$h))[0]; if ( $g_addr ne $new_addr ) { $g_addr = $global->{addr} = $new_addr; # find connection-field and replace address foreach my $line (@{ $global->{lines} }) { if ( $line->[0] eq 'c' ) { $line->[1] = _join_c( $new_addr ); last; # there is only one connection-field } } } } else { # the is no uniq mapping from old to new # this can be because old connection-field was never used # (because each media section had it's own) or that # different new addr gets used for the same old addr # -> remove global connection line $g_addr = $global->{addr} = undef; my $l = $global->{lines}; @$l = grep { $_->[0] ne 'c' } @$l; } } # remap addr,port in each media section # if new addr is != $g_addr and I had no connection-field # before I need to add one for( my $i=0;$i<@$media;$i++ ) { my $m = $media->[$i]; my $r = $replace[$i]; # replace port in media line if ( $r->[1] != $m->{port} ) { $m->{port} = $r->[1]; # [m]edia line should be the first my $line = $m->{lines}[0]; $line->[0] eq 'm' || die "[m]edia line is not first"; # media port(/range)... if ( $r->[1] ) { # port!=0: replace port only $line->[1] =~s{^(\S+\s+)\d+}{$1$r->[1]}; } else { # port == 0: replace port and range with '0' $line->[1] =~s{^(\S+\s+)\S+}{${1}0}; } } # replace addr in connection line if ( $r->[0] ne $m->{addr} ) { $m->{addr} = $r->[0]; my $have_c = 0; foreach my $line (@{ $m->{lines} }) { if ( $line->[0] eq 'c' ) { $have_c++; $line->[1] = _join_c($r->[0]); last; # there is only one connection-field } } if ( !$have_c && ( ! $g_addr || $r->[0] ne $g_addr )) { # there was no connection-field before # and the media addr is different from the global push @{ $m->{lines} },[ 'c', _join_c( $r->[0] ) ]; } } } } ########################################################################### # extract addr from [c]connection field and back ########################################################################### sub _split_c { my ($ntyp,$atyp,$addr) = split( ' ',shift,3 ); $ntyp eq 'IN' or die "nettype $ntyp not supported"; if ( $atyp eq 'IP4' ) { die "bad IP4 address: '$addr'" if ! ip_is_v4($addr); } elsif ( $atyp eq 'IP6' ) { die "bad IP6 address: '$addr'" if ! ip_is_v6($addr); } else { die "addrtype $atyp not supported" } return $addr; } sub _join_c { my $addr = shift; my $atyp = $addr =~m{:} ? 'IP6':'IP4'; return "IN $atyp $addr"; } ########################################################################### # extract data from [m]edia field and back ########################################################################### sub _split_m { my $mline = shift; my ($media,$port,$range,$proto,$fmt) = $mline =~m{^(\w+)\s+(\d+)(?:/(\d+))?\s+(\S+)((?:\s+\S+)+)} or die "bad [m]edia: '$mline'"; $range ||= 1; $range *=2 if $proto =~m{^RTP/}; # RTP+RTCP return ($media,$port,$range,$proto, [ split( ' ',$fmt) ]); } sub _join_m { my ($media,$port,$range,$proto,@fmt) = @_; @fmt = @{$fmt[0]} if @fmt == 1 && ref($fmt[0]); $range /= 2 if $proto =~m{^RTP/}; $port .= "/$range" if $range>1; return join( ' ',$media,$port,$proto,@fmt ); } 1; Net-SIP-0.822/lib/Net/SIP/Simple.pod0000644000175100017510000002121113370543213015316 0ustar workwork =head1 NAME Net::SIP::Simple - Simple interface for using Net::SIP =head1 SYNOPSIS use Net::SIP; # create new agent my $ua = Net::SIP::Simple->new( outgoing_proxy => '192.168.0.10', registrar => '192.168.0.10', domain => 'example.com', from => 'me', auth => [ 'me','secret' ], ); # Register agent $ua->register; # Invite other party, send announcement once connected my $call = $ua->invite( 'you', init_media => $ua->rtp( 'send_recv', 'announcement.pcmu-8000' ), asymetric_rtp => 1, ); # Mainloop $ua->loop; =head1 DESCRIPTION This package implements a simple layer on top of L, L and L. With the help of this package it is possible to write simple SIP applications with a few lines perl code. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) Creates new Net::SIP::Simple object. It will return the new object for further operations, but the object itself will contain back references to itself in the form of callbacks into the eventloop and dispatcher. This means that that object will not self-destroy, but you need to call B if you want it to go away. %ARGS can be: =over 8 =item outgoing_proxy|proxy C<< "ip:port" >> of outgoing proxy. The necessary L to the proxy will be created if no leg exists. =item registrar C<< "ip:port" >> of registrar. Used in method B if there is no other registrar given. =item legs|leg \@List of legs or single leg. Leg can be an existing L (or derived) object, an L (existing socket), a hash reference which can be used in the constructor of L or a string of C<< "proto:ip:port" >>. In the latter case C can be omitted (including the colon) and defaults to 'udp' and C can be omitted to (including the colon) defaulting to 5060. Either B or B has to be provided, e.g. it needs at least one leg. =item auth Authorization data, see method B in L for details about the format. =item domain Default domain for not fully qualified SIP addresses in C and C (method B). =item from SIP address of local sender, either full SIP address or only part before \@, in which case B has to be provided. =item contact SIP address of local sender, which should be used in the contact header of REGISTER and INVITE requests. If not given B will be used. =item options This is a hash reference containing headers (header-key,value) for replies to an OPTIONS request. If not or only partly given defaults will be used for the headers B, B, B, B and B. =item route Optional list of SIP routes which will be added to route requests. =item loop Eventloop object for dispatcher, see L. Usually not given, because the loop from the dispatcher will be used, but can be given if no dispatcher was given. =item dispatcher L object. Usually not given and will be created, but sometimes one need to share the same dispatcher between multiple L objects. =item domain2proxy|d2p Hash with mapping between domain and upstream proxy. See same key in the constructor of L for more details. =item tls Common TLS settings for all legs which will be created by this object. See C in L for more details. =back =back =head1 METHODS =over 4 =item cleanup Cleans up object, removes legs it added from the dispatcher. Needs to be called if you want to destroy the object, because it will not self-destroy (see B). =item error ( ERROR ) Either sets current error (used internally) or returns last error. =item loop ( [ TIMEOUT, @STOPVAR ] ) Calls the event loops (key B in constructor> B method. TIMEOUT is the timeout for the loop in seconds. If not given it will not stop because of timeout. @STOPVAR is a list of scalar references, will stop the loop if any of these references contains TRUE. See method B in L for more details. The order of TIMEOUT or the STOPVARs is insignificant, e.g. if it finds a reference it will use it as stopvar, otherwise it's used as timeout. =item add_timer ( WHEN, CALLBACK, [ REPEAT ] ) Calls same method from the L object in C<$self>. See there for details on arguments. =item rtp ( METHOD,@ARGS ) Calls the method METHOD in L with arguments @ARGS. Currently only does this and thus works as a shortcut. In the future one might add more ways to find the right method for RTP handling (e.g. plugins or similar). =item register ( %ARGS ) Registers the user agent. %ARGS can have the key B which has precedence over the same key in the constructor. B specifies the leg where the register request will be send through. If not given it will pick the right leg. If B is specified it is a callback usable by B in L which will be called, once the registration is completed (e.g. it succeeded or failed). If no B is specified the method will wait, until the registration is completed and return either the expires time given by the registrar or C<()> if registration failed. All other keys, like B, B, B, B will be forwarded to method B in L. B and B will be used from %ARGS or if not in %ARGS from the constructor. =item invite ( CTX,%ARGS ) Creates a new call and invites peer. Creates a new L object with context CTX and creates an INVITE request for this call using %ARGS. See B in L for more info on %ARGS. CTX can be address of peer or context hash containing the address. Returns with the newly created L object, which can later be used for reINVITEs or BYE etc. Note that in order to have any callbacks triggered by the invite working one needs to keep the returned caller object. =item listen ( %ARGS ) Sets up waiting on all legs in C<$self> for incoming calls, e.g. new INVITE requests. All other incoming packets will be dropped. If a call comes in a new L object will be created using %ARGS. The method does not wait for the calls, its setting only the callback on the legs up. Thus it has to be followed by a call to B. If %ARGS contain C keys an Authorizer will be added before the listener. See L for the keys, e.g. C will be forwarded as C etc to the authorizer. Special keys not described in L: =over 8 =item filter A callback usable by B in L which gets called with the value of the B header and the L object from the incoming request. If the callback returns TRUE the call gets accepted, otherwise not. =item cb_create Callback which will be called on accepting the call. Will be called with C<< CALL,REQUEST,LEG,FROM >> where CALL is the newly created L object, REQUEST the creating L packet, LEG the incoming leg and FROM the C<< "ip:port" >> of the sender. Must return TRUE or the call gets not answered. =item cb_established Callback which will be called, after the call is established, e.g. after receiving the ACK from the peer. Will be invoked with 'OK' and the L object as argument. =item cb_cleanup Callback which will be called when the call gets closed to clean up allocated resources. Will be invoked with the L object as argument. =back =item create_auth ( %ARGS ) Sets up authorization. See L for the meaning of %ARGS. The returned object should be used together with other objects within C. =item create_registrar ( %ARGS ) Sets up a simple registrar using L. See there for the meaning of %ARGS. Like with B you need to B after calling this method, the method itself will not wait. Like with B authorization can be added uses C keys. =item create_stateless_proxy ( %ARGS ) Sets up a simple proxy using L. See there for the meaning of %ARGS. Like with B you need to B after calling this method, the method itself will not wait. Like with B authorization can be added uses C keys. =item create_chain ( OBJECTS, %ARGS ) Sets up a chain using L. See there for the meaning of OBJECT and %ARGS. Like with B you need to B after calling this method, the method itself will not wait. =back Net-SIP-0.822/lib/Net/SIP/SocketPool.pod0000644000175100017510000001224113061727567016167 0ustar workwork =head1 NAME Net::SIP:::SocketPool - manage sockets related to a leg =head1 SYNOPSIS my $pool = Net::SIP::SocketPool->new(...) $pool->sendto($packet, [ip,port,family], \&callback) =head1 DESCRIPTION B manages a collection of sockets associated with a B. This is usually an unconnected socket (i.e. UDP or TCP listen socket) and mayby some connected sockets. While in UDP a packet can be received and sent using an unconnected socket this is not possible in TCP and therefore these connected socket have to be maintained somehow. Also, it is expected in TCP that a response will be sent back through the same TCP connection as the request came in, if possible. B is usually not used directly but will be created when a new B gets created. =head1 CONSTRUCTOR =over 4 =item new (PROTO, FD, DST, CONNECTED, [TLS]) The constructer creates a new B for protocol B (C, C or C) with B as the master socket. If B is true this master socket is connected and B will in this case be interpreted as the peer of the socket. But a connected master socket makes only sense for UDP and only if the communication should be limited to specific party, like an outgoing SIP proxy. In the common case that B is false the optional B given as C<< [ip, port, family] >> will be interpreted as restriction for the communication, i.e. it will be forced as destination in B no matter what was given and it will be checked that any received data origin from the expected peer B. With the optional B argument a hash can be givevn wth arguments used in creation of the L objects when is C. This typically includes location of the certificate and key with C and C. These arguments will be used for both server and client SSL sockets which also means that the certificate configured as server certificates will also be used as client certificates if the peer requires authentication with client certificates. The special argument C in B can be used to require authentication with client certificates by the peer. It can be set to C<0> for no client certificates, C<-1> for optional and C<1> for required client certificates. =back =head1 METHODS =over 4 =item sendto(PKT, DST, CALLBACK) This method is used indirectly from B to deliver a new packet to its destinination. This will deliver the L B to the target B given as hash with C, C, C and will invoke B when done. Callback can be anything accepted by B from L. With TCP the B will try to find an existing connected socket to the target first before creating a new one. For response packets it will prefer the socket where the request packet came in, if possible. With UDP instead it will just use the master socket for sending. =item master This will just return the FD for the master socket. This is used by B in case the B was created outside the B. =item attach_eventloop(LOOP, CALLBACK) This attaches the B to a L object so that it can be used for event based I/O. This attaches B as read handler to the given B to handle new packets coming in through the sockets inside the B. It will accept any callback suitable for B and will invoke it with C<< [PKT, FROM] >> where B is the freshly read L and B the origin of this packet as hash. This hash includes C, C of the sender, C of the socket, C as the used protocol (i.e. 'udp', 'tcp' or 'tls') and C for the local socket object where the packet was received on. This socket is either an IO::Socket or IO::Socket::SSL object and is only intended for passive use, for example to extract the certificate send by the peer. If B is undef it will just detach from the current loop. This function is used from inside L to attach a legs sockets to the event loop and process incoming data. =back Additionally to these methods the internal configuration can be adjusted with C or C: use Net::SIP::SocketPool (MAX_SIP_HEADER => 2**14, ... ); The following settings are possible this way: =over 4 =item MAX_SIP_HEADER maximum size of SIP header, default C<2**14> =item MAX_SIP_BODY maximum size of SIP body, default C<2**16> =item MAX_TIDLIST This is maximum size of remembered incoming requests per socket. These requests need to be remembered so that outgoing responses can be sent back through the same connection as the request came in. This defaults to 30. =item MIN_EXPIRE, MAX_EXPIRE The minimal time for socket expiration and the maximum time. These default to 15 and 120 (seconds). The exact time for expiration depends on the number of sockets in the socketgroup, i.e. the more sockets the shorter the expiration timeout. =item CONNECT_TIMEOUT The timeout used for establishing a TCP connection. Default to 10 (seconds). =item TCP_READSIZE The amount of data it tries to read within a single sysread, default 2**16. =back Net-SIP-0.822/lib/Net/SIP/ReceiveChain.pod0000644000175100017510000000437411332062323016417 0ustar workwork =head1 NAME Net::SIP::ReceiveChain - handle incoming packet by multiple receivers =head1 SYNOPSIS # create proxy which works as a registrar too, but # all register requests should be authorized my $registrar = Net::SIP::Registrar->new... my $auth = Net::SIP::Authorize->new .... my $reg_chain = Net::SIP::ReceiveChain->new( [ $auth,$registrar ], methods => [ 'REGISTER' ], ); my $proxy = Net::SIP::StatelessProxy->new... my $chain = Net::SIP::ReceiveChain->new( [ $registrar,$proxy ] ); =head1 DESCRIPTION This package is used to handle incoming packets by multiple receivers, e.g. make sure that requests for L will be authorized by L. Objects in the chain might be L, L, L, L itself and every other object which handles C like described below. =head1 CONSTRUCTOR =over 4 =item new ( OBJECTS, %ARGS ) This creates a new registar object, OBJECTS is a reference to an array of objects implementing the C method. %ARGS can have the following keys: =over 8 =item filter A callback which gets called during C with all arguments of the method. If it returns TRUE the packet will be handled by the chain, otherwise not. =item methods If B is not given but B is it will set B to a callback which accepts only the methods specified in the array reference given to B. =back =back =head1 METHODS =over 4 =item receive ( PACKET,LEG,FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. Responses will be send back to the sender through the same leg. Called from the managing L object if a new packet arrives. Returns TRUE if the packet was fully handled by one of the objects in the chain, else FALSE: =over 8 =item * If a filter was given checks the packet against the filter and returns FALSE if the filter does return FALSE. =item * Otherwise it will call C on all objects in the chain until one of these returns TRUE. In this case it will return TRUE. =item * If no object in the chain handled the packet it will return FALSE. =back =back Net-SIP-0.822/lib/Net/SIP/Endpoint/0000755000175100017510000000000013552315100015136 5ustar workworkNet-SIP-0.822/lib/Net/SIP/Endpoint/Context.pod0000644000175100017510000002203313005561434017274 0ustar workwork =head1 NAME Net::SIP::Endpoint::Context - Call context for endpoint =head1 SYNOPSIS my $ctx = Net::SIP::Endpoint::Context->new( to => .., from => .. ); my $request = $ctx->new_request(..); =head1 DESCRIPTION This package manages the call context (from,to,call-id, recorded routes..) for a call to an L. It maintains the state of the current call (local and remote cseq, current state within INVITE transaction) and handles requests and responses according to this state. =head1 CONSTRUCTOR =over 4 =item new ( ARGS ) ARGS is either a hash reference or a hash. It contains the following mandatory keys: =over 8 =item from Initiator of call. This is the local address for outgoing calls and the peers address for incoming calls. =item to Target of call. =back And the following optional keys: =over 8 =item contact Contact info for context. =item incoming Flag, if the context resulted from an incoming call. =item auth Authorization info, used if outgoing requests need authorization. See method B in L for information on the format. =item route \@List of predefined routes (which will be used to create B SIP header in requests). =item via \@List of predefined B values used in locally generated responses. This is usually set if the context was created by an incoming request from the B header in the request. =item callid Value of B header. If not given it will be generated. It's usually given for incoming calls, but not for outgoing calls. =item cseq Initial local sequence number for the B SIP header. Defaults to 0, e.g. the first request will get the sequence number 1. =back =back =head1 METHODS =over 4 =item callid Returns callid of current call. =item peer Returns peer of call. For incoming calls this is the sender, for outgoing calls the recipient of the call. =item new_request ( METHOD, [ BODY, %ARGS ] ) Creates a new requests for method METHOD with body BODY and additional SIP headers defined by %ARGS. The headers for C, C, C, C will be created from the call context info in C<$self>. One special ARGS can be B which should point to a 401/407 SIP response containing the offer from the server for authorization. This way authorization can be fully controlled, e.g. first trying w/o authorization and then retrying with authorization credentials and the 40x response. METHOD might be already a L object in which case it will be used unmodified. BODY might be a string or object (see constructor of L). It will add the request to the list of active transactions within the context C<$self>, e.g. will be prepared to get responses for it. The callback for the transaction is copied from the default callback for the context, so that it stays the same, even if the default callback changes. It returns the created request object. =item find_outstanding_requests ( %FILTER ) Returns list of outstanding requests (e.g INVITE w/o reply) for this context. Returns a list of outstanding request (L objects) with the most recent requests first. FILTER might be used to restrict the search. With key B a L object is expected and it will restrict the search to this object (e.g. it will return the object if it is outstanding). With key B a method can be specified and only requests with this method will be returned. =item set_callback ( CALLBACK ) Sets callback for context, which will be used if the upper layer need to be notified, e.g on incoming requests or an permanent delivery errors. CALLBACK is a callback usable by B in L and will be invoked with the following arguments (some arguments make only sense for incoming packets). =over 8 =item CTX The call context, e.g. C<$self>. =item ENDPOINT The L object managing CTX. =item ERROR The errno of the error occurred ( undef or 0 if no error ). These are the same numbers defined in L, but they are usually not set by a system call, but by the dispatcher (like ETIMEDOUT if delivery failed permanently after none of the retransmits succeeded or EHOSTUNREACH if it cannot resolve the SIP URI). =item CODE This is the response CODE from an incoming response packet. Undef if the incoming packet was no response. =item PACKET This is the packet which caused the callback. Only for incoming packets. =item LEG L where the packet came in. =item FROM C<< "ip:port" >> of sender of incoming packet. =back =item request_delivery_done ( ENDPOINT, TID, ERROR ) Callback setup at delivery of the packet and called with ERROR FALSE if the packet was delivered successfully over a reliable transport or with ERROR an errno if the packet could not be delivered (or no reply came in for packet, so one can assume that the recipient did not get it). For details on ERROR see B. TID is the transaction ID, see method B in L. ENDPOINT is the endpoint managing the context C<$self>. =item handle_response ( RESPONSE,LEG,FROM,ENDPOINT ) Called from the endpoints B method it handles responses to requests originated from the context C<$self>. RESPONSE is the response packet, LEG the leg where the packet came in and FROM the C<< "ip:port" >> of the sender. ENDPOINT is the endpoint managing the context C<$self>. First it checks if the response matches an active transaction (which begun its life in B) and if not it drops the response. Then it checks if the response came in to the right leg, e.g. if the B header of the packet matches the B header the leg creates. If not the packet will be dropped. Then it checks if the method in the B header of the response matches the expected method in the transaction (for INVITEs this could be either INVITE or ACK, depending on the state of the transaction). If it not matches the packet will be dropped. (All of these packet drops could be observed if you enable debugging, see L. If the response is for a BYE or CANCEL request the call will be closed. If the response is the unsuccessful final response for an INVITE an ACK will be send, if it's preliminary response it will invoke the callback for the transaction. If the response is a successful final response for an INVITE it will save the routes from the B header for future requests and create an ACK request. The transaction callback will be invoked and gets as an additional argument the created ACK request, which then can be modified by the callback. The callback should not send the ACK request by itself, it should just modify the given request and sending will be done after the callback returned. If the response is a successful final response to a request other then INVITE it will invoke callback which should fully handle the response. If the response code is 401 (Unauthorized) or 407 (Proxy Authentication Required) and if the context has authorization info (key B in the constructor)) it will try to authorize the request based on the realms given in the response and if it can find authorization info for at least parts of the required realms it will redeliver the request. Otherwise it will invoke the callback with an error of EPERM. If the response code is 300 (Multiple Choices) or 301 (moved permanently) it will invoke the callback because it cannot resolve the issue automatically. But if it's 302 (Moved Temporarily) it will rewrite the request based on the B header in the response and redeliver it automatically. If the response is 305 (Use Proxy) it will take the information from B as the upstream proxy and insert it into the routes, so that it will use it as the next hop. Then it rewrites the request for the new routes and redelivers it. For all other responses the callback will be invoked, e.g the issue has to be resolved by the users application. =item handle_request ( REQUEST,LEG,FROM,ENDPOINT ) Called from the endpoints B method it handles incoming requests for call context C<$self>. REQUEST is the request packet, LEG the leg where the packet came in and FROM the C<< "ip:port" >> of the sender. ENDPOINT is the endpoint managing the context C<$self>. First it checks if the sequence number of the incoming request (B header) is not lower then the sequence number of the last request received. Otherwise it will drop the request. The it checks if the sequence number is the same as for the last request. If it is higher it must be a new request, otherwise it is a retransmit or an ACK or CANCEL to an INVITE request. If it's a retransmit it will be dropped. If the incoming request is an INVITE it will automatically deliver a response C<< 100 Trying >> and then invoke the callback, so that the application might issue C<< 180 Ringing >> responses and finally a final response, like C<< 200 Ok >>. If the incoming request is CANCEL or BYE it will issue a response C<< 200 Closing >> and close the context. All other requests must be handled by the application, e.g. the callback will be invoked. =back Net-SIP-0.822/lib/Net/SIP/Endpoint/Context.pm0000644000175100017510000004644713551637244017156 0ustar workwork ############################################################################ # Net::SIP::Endpoint::Context # the calling context for a call managed by the endpoint ############################################################################ use strict; use warnings; package Net::SIP::Endpoint::Context; use fields ( # ===== can be set with new() 'method', # initiated by which method 'from', # from where 'to', # to where 'auth', # [ user,pass ] or { realm1 => [ user1,pass1 ], realm2 => [ user2,pass2 ],... } # or callback(realm,user)->pass # if given, handle_response might automatically try to authorize requests 'contact', # optional local contact 'remote_contact', # remote contact from response 'callid', # call-id value 'cseq', # number in cseq header 'route', # for 'route' header, comes usually from 'record-route' info in response 'via', # for 'via' header in created responses, comes from incoming request 'incoming', # flag if call is incoming, e.g. 'to' is myself 'local_tag', # local tag which gets assigned to either from or to depending on incoming # ===== Internals # \@array of hashrefs for infos about pending transactions '_transactions', # arrayref specifying a user defined callback for request success or failure '_callback', # cseq counter for incoming requests '_cseq_incoming', # last request in current incoming transaction '_last_transreq', ); use Digest::MD5 'md5_hex'; use Net::SIP::Request; use Net::SIP::Response; use Net::SIP::Debug; use Errno qw( EINVAL EPERM EFAULT ); use Hash::Util 'lock_keys'; use List::Util 'first'; use Net::SIP::Util ':all'; ############################################################################ # Creates new context # Args: ($class,@args) # @args: either single \%args (hash-ref) or %args (hash) with at least # values for from and to # callid,cseq will be generated if not given # routes will default to undef and usually set from record-route header # in response packets # Returns: $self ############################################################################ sub new { my $class = shift; my %args = @_ == 1 ? %{ shift(@_) } : @_; my $self = fields::new( $class ); %$self = %args; $self->{callid} ||= md5_hex( time(), rand(2**32) ); $self->{cseq} ||= 0; $self->{_transactions} = []; $self->{_cseq_incoming} = undef; # create tag on my side (to|from) my $side = $self->{incoming} ? 'to':'from'; my ($data,$param) = sip_hdrval2parts( $side => $self->{$side} ); if ( my $tag = $param->{tag} ) { # FIXME: what to do if local_tag was already set to different value? $self->{local_tag} = $tag; } else { $self->{$side}.=";tag=".( $self->{local_tag} = md5_hex( time(), rand(2**32), $self->{$side} ) ); } DEBUG( 100,"CREATE context $self callid=$self->{callid}" ); return $self } # destroying of fields in perl5.8 cleanup can cause strange errors, where # it complains, that it cannot coerce array into hash. So use this function # on your own risks and rename it to DETSTROY if you want to have debugging # info sub _DESTROY { DEBUG( 100,"DESTROY context $_[0] callid=$_[0]->{callid}" ); } ############################################################################ # returns callid for context # Args: $self # Returns: $id ############################################################################ sub callid { my Net::SIP::Endpoint::Context $self = shift; return $self->{callid}; } ############################################################################ # get peer # Args: $self # Returns: $peer # $peer: for incoming calls this is 'from', for outgoing 'to' ############################################################################ sub peer { my Net::SIP::Endpoint::Context $self = shift; my $peer = $self->{incoming} ? $self->{from} : $self->{to}; my ($data) = sip_hdrval2parts( from => $peer ); # strip parameters like tag etc return $data; } ############################################################################ # return list of outstanding requests matching filter, if no filter is given # returns all requests # Args: ($self,%filter) # %filter # method => name: filter for requests with given method # request => packet: filter for packet, e.g. finds if packet is outstanding # Returns: @requests # returns all matching requests (Net::SIP::Request objects), newest # requests first ############################################################################ sub find_outstanding_requests { my Net::SIP::Endpoint::Context $self = shift; my %filter = @_; my @trans = @{$self->{_transactions}} or return; if ( my $pkt = $filter{request} ) { @trans = grep { $pkt == $_->{request} } @trans or return; } if ( my $method = $filter{method} ) { @trans = grep { $method eq $_->{request}->method } @trans or return; } return map { $_->{request} } @trans; } ############################################################################ # creates a new SIP request packet within this context # Args: ($self,$method;$body,%args) # $method: method for request, eg 'INVITE','BYE'... # or already a Net::SIP::Request object # $body: (optional) body for SIP packet # %args: (optional) additional args given to Net::SIP::Request->new # Returns: $request # $request: Net::SIP::Request object ############################################################################ sub new_request { my Net::SIP::Endpoint::Context $self = shift; my ($method,$body,%args) = @_; my ($leg,$dst_addr,$rsp40x) = delete @args{qw(leg dst_addr resp40x)}; my $request; if ( ref($method)) { # already a request object $request = $method; $method = $request->method; } else { # increase cseq unless its explicitly specified # the latter case is useful for ACK and CANCEL # which need the same sequence number as the INVITE # they belong to my $cseq = delete $args{cseq} || ++$self->{cseq}; $method = uc($method); my $uri = delete $args{uri}; my ($to,$from) = $self->{incoming} ? ($self->{from},$self->{to}) : ($self->{to},$self->{from}); if ( !$uri ) { $uri = $self->{remote_contact} || (sip_hdrval2parts(to => $to))[0]; # XXX handle quotes right, e.g "" $uri = $1 if $uri =~m{<(\S+)>$}; } # contact is mandatory for INVITE # will be added within Leg $request = Net::SIP::Request->new( $method, # Method $uri, # URI { from => $from, to => $to, $self->{contact} ? ( contact => $self->{contact} ):(), cseq => "$cseq $method", 'call-id' => $self->{callid}, 'max-forwards' => 70, %args, }, $body ); } # overwrite any route header in request if we already learned a route $request->set_header( route => $self->{route} ) if $self->{route}; if ( $rsp40x and $self->{auth} and $request->authorize( $rsp40x, $self->{auth} )) { # update local cseq ($self->{cseq}) = $request->cseq =~m{(\d+)}; } # create new transaction my %trans = ( tid => $request->tid, request => $request, callback => $self->{_callback}, # we need this to resent the request with authentication the same way leg => $leg, dst_addr => $dst_addr, ); lock_keys(%trans); unshift @{ $self->{_transactions} }, \%trans; # put as first return $request; } ############################################################################ # set callback for context # Args: ($self,$cb) # $cb: [ \&sub,@arg ] # Returns: NONE ############################################################################ sub set_callback { my Net::SIP::Endpoint::Context $self = shift; $self->{_callback} = shift; } ############################################################################ # notify context that current delivery is permanently done (e.g successful # or failed). On failure call current callback to notify upper layer about # permanent failure of request # This is used for errors from the transport layer, errors from the SIP # layer (e.g response with 400 Bad request) are handled by handle_response() # Args: ($self,$tid;$error) # $tid: Transaction ID # $error: errno if error occurred # Returns: NONE ############################################################################ sub request_delivery_done { my Net::SIP::Endpoint::Context $self = shift; my ($endpoint,$tid,$error) = @_; return if ! $error; # notify of success once I get response my $trans = $self->{_transactions}; my @ntrans; foreach my $tr (@$trans) { if ( $tr->{tid} eq $tid ) { $self->{_transactions} = \@ntrans; if ( my $cb = $tr->{callback} ) { # permanently failed invoke_callback( $cb,$endpoint,$self,$error ); } } else { push @ntrans,$tr } } } ############################################################################ # handle response packet for this context # cseq of response must match the cseq of the current delivery! # if there is no current delivery or the cseq does not match the response # gets dropped # Args: ($self,$response,$leg,$from,$endpoint) # $response: incoming Net::SIP::Response packet # $leg: Net::SIP::Leg through which the response came in # $from: hash with information where response came in # $endpoint: endpoint responsable for this context, used for redeliveries... # Returns: NONE ############################################################################ sub handle_response { my Net::SIP::Endpoint::Context $self = shift; my ($response,$leg,$from,$endpoint) = @_; # find and remove transaction because I got response for it # if response does not terminates transaction one need to add # it again my $tid = $response->tid; my $method = $response->method; my $trans = $self->{_transactions}; my (@ntrans,$tr); foreach my $t (@$trans) { if ( !$tr and $t->{tid} eq $tid and $method eq $t->{request}->method) { $tr = $t; } else { push @ntrans,$t } } $tr || do { # no delivery pending DEBUG( 10,"got response for unkown transaction. DROP" ); return; }; $self->{_transactions} = \@ntrans; DEBUG( 10,"got response for transaction ".$tr->{request}->dump ); # match response to client transaction, RFC3261 17.1.3 # check if the response came in through the same leg, where the # request was send, e.g that the branch tag is the same $leg->check_via( $response ) || do { DEBUG( 10,"response came in through the wrong leg" ); return; }; my $cb = $tr->{callback}; my @arg = ($endpoint,$self); my $code = $response->code; # for 300-699 an ACK must be created (RFC3261, 17.1.1.2) # notification of upper layer will be done down in the method # XXXXXXXXXXXXXX do we need to wait that the ACK was accepted # XXXXXXXXXXXXXX before sending new request?? # XXXXXXXXXXXXXX (e.g for 401,407,302..) if ( $method eq 'INVITE' && $code>=300 ) { # must create ACK DEBUG( 50,"code=$code, must generate ACK" ); my $ack = $tr->{request}->create_ack( $response ); $endpoint->new_request( $ack,$self,undef,undef,leg => $leg); } # transaction is not done if ( $code =~m{^1\d\d} ) { push @ntrans,$tr; # forward preliminary responses to INVITE to app # ignore all other preliminary responses if ( $method eq 'INVITE' ) { invoke_callback($cb,@arg,0,$code,$response,$leg,$from); } return; } # Authorization required if ( $code == 401 || $code == 407 ) { my $r = $tr->{request}; my $auth = $self->{auth}; if ( $auth && $r->authorize( $response, $auth )) { DEBUG(10,"retrying with authorization"); # found something to authorize # redo request # update local cseq from cseq in request ($self->{cseq}) = $r->cseq =~m{(\d+)}; $endpoint->new_request($r, $self, undef, undef, leg => $tr->{leg}, dst_addr => $tr->{dst_addr}); } else { # need user feedback DEBUG(10,"no (usable) authorization data available"); invoke_callback($cb,@arg,EPERM,$code,$response,$leg,$from); } return; } # Don't care about the response for a CANCEL or a BYE # because this connection close is issued by this side # and no matter what the peer wants the call be will closed # But invoke callback to notify upper layer if ( $method eq 'CANCEL' or $method eq 'BYE' ) { invoke_callback($cb,@arg,0,$code,$response,$leg,$from); # close context only for BYE, # for CANCEL we will close the context on receiving the # response and sending the ACK $endpoint->close_context( $self ) if $method eq 'BYE'; return; } # final response in non-dialog (only INVITE can create dialog) if ( $self->{method} ne 'INVITE' and ($code>=200 and $code<300 or $code>=400)) { $endpoint->close_context($self); } if ( $code =~m{^2\d\d} ) { # 2xx OK if ( $method eq 'INVITE' ) { # is response to INVITE, create ACK # and propagate to upper layer my $req = $tr->{request}; # extract route information on INVITE, but not on re-INVITE # we assume, that it is a re-INVITE, if we have a remote_contact # already if ( ! $self->{remote_contact} and my @route = $response->get_header( 'record-route' )) { $self->{route} = [ reverse @route ]; } # 12.1.2 - set URI for dialog to contact given in response which # establishes the dialog if ( my $contact = $response->get_header( 'contact' )) { $contact = $1 if $contact =~m{<(\w+:[^>\s]+)>}; $self->{remote_contact} = $contact; $req->set_uri( $contact ); } # use to-tag from this request to update 'to' # FIXME: this should probably be better done by the upper layer # which decides, which call to accept (in case of call-forking with # multiple 2xx responses) $self->{to} = $response->get_header( 'to' ) if ! $self->{incoming}; # create ACK # if 2xx response changed contact use it as the new URI my $ack = $req->create_ack( $response ); invoke_callback($cb,@arg,0,$code,$response,$leg,$from,$ack); $endpoint->new_request( $ack,$self,undef,undef,leg => $leg); } else { # response to ACK, REGISTER... # simply propagate to upper layer, only INVITE needs # special handling invoke_callback($cb,@arg,0,$code,$response,$leg,$from); } } elsif ( $code == 300 || $code == 301 ) { # need user feedback in these cases # 21.3.1 300 multiple choices # 21.3.2 301 moved permanently invoke_callback($cb,@arg,EFAULT,$code,$response,$leg,$from); } elsif ( $code == 302 ) { # 21.3.3 302 moved temporarily # redo request and insert request again my $contact = $self->{to} = $response->get_header( 'contact' ); $contact = $1 if $contact =~m{<(\w+:[^>\s]+)>}; $self->{remote_contact} = $contact; ( my $r = $tr->{request} )->set_uri( $contact ); $r->set_cseq( ++$self->{cseq} ); $endpoint->new_request( $r,$self ); } elsif ( $code == 305 ) { # 21.3.4 305 use proxy # set proxy as the first route and insert request again my $route = $self->{route} ||= []; unshift @$route,$response->get_header( 'contact' ); ( my $r = $tr->{request} )->set_header( route => $route ); $r->set_cseq( ++$self->{cseq} ); $endpoint->new_request( $r,$self ); } else { # some kind of unrecoverable error invoke_callback($cb,@arg,EINVAL,$code,$response,$leg,$from); } } ############################################################################ # handle incoming request # Args: ($self,$request,$leg,$endpoint) # $request: incoming Net::SIP::Request packet # $leg: Net::SIP::Leg through which the request came in # $from: ip:port where request came in # $endpoint: endpoint responsable for this context, used for responses... # Returns: NONE # Comment: only new requests will be delivered to this method, because the dispatcher # cares about retransmits, eg requests for which I issued already a response # within the last 64*T1 ############################################################################ sub handle_request { my Net::SIP::Endpoint::Context $self = shift; my ($request,$leg,$from,$endpoint) = @_; my $cseq = $request->cseq; my ($cseq_num) = $cseq=~m{^(\d+)}; DEBUG( 100,"method=%s cseq=%s/%s inc=%s", $request->method, $cseq_num,$cseq, defined($self->{_cseq_incoming}) ? $self->{_cseq_incoming} : '' ); if ( defined $self->{_cseq_incoming} and $cseq_num < $self->{_cseq_incoming} ) { # must be an retransmit of an really old request, drop DEBUG( 10,"retransmit of really old request? Dropping" ); return; } # check with last request in transaction my $ctx_is_new; if ( my $trans = $self->{_last_transreq} ) { my $last_cseq = $trans->cseq; if ( $last_cseq eq $cseq ) { DEBUG( 10,"retransmit of last request. DROP" ); return; } } else { $ctx_is_new = 1; } $self->{_last_transreq} = $request; my $method = $request->method; if ( $method eq 'ACK' || $method eq 'CANCEL' ) { # must be have same cseq_num as last request, otherwise drop if ( defined $self->{_cseq_incoming} and $cseq_num != $self->{_cseq_incoming} ) { DEBUG( 10,"received $method for unreceived INVITE: $cseq_num|$self->{_cseq_incoming}" ); return; } } else { # cannot have the same cseq_num as last request if ( defined $self->{_cseq_incoming} and $cseq_num == $self->{_cseq_incoming} ) { DEBUG( 10,"reused cseq for $method. DROP" ); return; } } $self->{_cseq_incoming} = $cseq_num; my $cb = $self->{_callback} || do { DEBUG( 50,"no callback at context!" ); return; }; my @arg = ($endpoint,$self); # extract route information for future requests to the UAC (re-invites) # only for INVITE (rfc3261,12.1.1) if ( $ctx_is_new and $method eq 'INVITE' and my @route = $request->get_header( 'record-route' )) { $self->{route} = \@route; } { # check if to has already a (my) tag, if not add it to request, # so that it gets added to responses my $to = $request->get_header( 'to' ); my ($data,$param) = sip_hdrval2parts( to => $to ); if ( ! $param->{tag} ) { DEBUG( 50,"added my tag to to header in request" ); $param->{tag} = $self->{local_tag}; $to = sip_parts2hdrval( 'to',$data,$param ); $request->set_header( to => $to ); } } if ( $method eq 'BYE' || $method eq 'CANCEL' ) { # if the peer wants to hangup we must confirm my $response = $request->create_response( '200','Closing' ); $endpoint->new_response( $self,$response,$leg,$from ); # invoke callback before closing context, so that we have more # information about the current call invoke_callback($cb,@arg,0,0,$request,$leg,$from); if ( $method eq 'CANCEL' ) { # must create 487 Request canceled my $response = $request->create_response( '487','Request canceled' ); $response->set_header( cseq => $response->cseq =~m{(\d+)} && "$1 INVITE" ); DEBUG(10,"send response: ".$response->dump(1)); $endpoint->new_response($self,$response,$leg,$from); } $endpoint->close_context($self); return; } # If new INVITE, send 100 Trying if ( $method eq 'INVITE' ) { my $response = $request->create_response( '100','Trying' ); $endpoint->new_response( $self,$response,$leg,$from ); } # propagate to upper layer, which needs # - for INVITE send 180 Ringing periodically and after some time a final response # - for ACK to establish the call # - BYE|CANCEL is already handled above # - for everything else to handle the Option fully, eg issue final response.. invoke_callback($cb,@arg,0,0,$request,$leg,$from); } 1; Net-SIP-0.822/lib/Net/SIP/DTMF.pod0000644000175100017510000000516511774636365014652 0ustar workwork=head1 NAME Net::SIP::DTMF - DTMF RTP packet generating and extracting =head1 SYNOPSIS use Net::SIP::DTMF; my $sub = dtmf_generator( 11, # event '#' 100, # duration 100ms rfc2833_type => 101, # RTP type 101 for telephone-event/8000 # audio_type => 0, # RTP type 0 for PCMU/8000 ); while (...) { my @pkt = $sub->($sequence,$timestamp,$srcid); last if ! @pkt; # dtmf done next if $buf[0] eq ''; # more coming, but no data this time (pause) .. send @pkts ... } use Net::SIP::DTMF; my $sub = dtmf_extractor( rfc2833_type => 101, # RTP type 101 for telephone-event/8000 audio_type => 0, # RTP type 0 for PCMU/8000 ); while (...) { if ( my ($event,$duration,$type) = $sub->($packet)) { # event received ... } } =head1 DESCRIPTION This package provides functions for generating RTP packets containing DTMF events or extracting DTMF events from RTP packets. =head1 FUNCTIONS =over 4 =item dtmf_generator ( EVENT, DURATION, %ARGS ) Generates a function which is used to generate packets for the given EVENT. EVENT is the event numer (0..15) or undef if it should just generate silence or pause. DURATION is the time for the event in ms. ARGS contain information how the event should be packed: either as RFC2833 RTP event or as RTP audio PCMU/8000. %ARGS can be =over 8 =item rfc2833_type => rtp_type Gives the RTP payload type number for rfc2833 RTP events (telephone-event/8000). If not given will try B instead. =item audio_type => rtp_type Gives the RTP payload type number for PCMU/8000. If not given and no B given it will croak. =item volume => volume Sets the volume for RTP event according to rfc2833. =back The generated function should then be called with SEQUENCE,TIMESTAMP,SRCID to generate the RTP packets and will return @RTP_PACKETS, with =over 8 =item () - DTMF event is finished =item $RTP_PACKETS[0] eq '' - no RTP packet for this call (pause) =item @RTP_PACKETS - RTP packets which can be send to the peer =back =item dtmf_extractor ( %ARGS ) Generates a function which is used to extract DTMF events. Keys B and B have the same meaning as in B. It will only attempt to extract DTMF events from rfc2833 RTP events or audio if the relevant rtp_type is given. The function will be called with the RTP packet as the only argument and will return () if no new events where found or (EVENT,DURATION,TYPE) if an event finished, where DURATION is the duration in ms and TYPE is audio|rfc2833. For performance reasons it is best to use only rfc2833 if the peer supports it. =back Net-SIP-0.822/lib/Net/SIP/ReceiveChain.pm0000644000175100017510000000463112271422677016264 0ustar workwork########################################################################### # package Net::SIP::ReceiveChain # used to put Authorize, Registrar, StatelessProxy etc together so that # the object first in chain will try to handle the packets first and # pass them only to the next object if it was not fully handled by the # previous object # each object in chain returns TRUE from method receive if it handled # the packet fully ########################################################################### use strict; use warnings; package Net::SIP::ReceiveChain; use fields qw( objects filter ); use Net::SIP::Util 'invoke_callback'; ########################################################################### # creates new ReceiveChain object # Args: ($class,$objects,%args) # $objects: \@list of objects which it should put in the chain # %args: # filter: callback invoked on each packet to find out if it should # be processed by this chain # methods: \@list of methods, used if no filter is given # Returns: $self ########################################################################### sub new { my ($class,$objects,%args) = @_; my $self = fields::new( $class ); if ( ! ( $self->{filter} = $args{filter} )) { if ( my $m = $args{methods} ) { # predefined filter to filter based on method my %m = map { $_ => 1 } @$m; my $method_filter = sub { my ($hm,$packet) = @_; return $hm->{ $packet->method } }; $self->{filter} = [ $method_filter, \%m ]; } } $self->{objects} = $objects; return $self; } ########################################################################### # handle packet, called from Net::SIP::Dispatcher on incoming requests # Args: ($self,$packet,$leg,$addr) # $packet: Net::SIP::Packet # $leg: Net::SIP::Leg where request came in (and response gets send out) # $addr: ip:port where request came from and response will be send # Returns: TRUE if it handled the packet ########################################################################### sub receive { my Net::SIP::ReceiveChain $self = shift; my ($packet,$leg,$addr) = @_; if ( my $f = $self->{filter} ) { # check if packet should be handled by filter return if ! invoke_callback($f,$packet,$leg,$addr); } foreach my $object (@{ $self->{objects} }) { my $handled = $object->receive($packet,$leg,$addr); return $handled if $handled; } return; # not handled } 1; Net-SIP-0.822/lib/Net/SIP/Request.pm0000644000175100017510000002550713535453162015371 0ustar workwork########################################################################### # package Net::SIP::Request # subclass from Net::SIP::Packet for managing the request packets # has methods for creating ACK, CANCEL based on the request (and response) # and for adding Digest authorization (md5+qop=auth only) to the # request based on the requirements in the response ########################################################################### use strict; use warnings; package Net::SIP::Request; use base 'Net::SIP::Packet'; use Net::SIP::Debug; use Net::SIP::Util 'invoke_callback'; use Digest::MD5 'md5_hex'; my %ResponseCode = ( # Informational 100 => 'Trying', 180 => 'Ringing', 181 => 'Call Is Being Forwarded', 182 => 'Queued', 183 => 'Session Progress', # Success 200 => 'OK', # Redirection 300 => 'Multiple Choices', 301 => 'Moved Permanently', 302 => 'Moved Temporarily', 305 => 'Use Proxy', 380 => 'Alternative Service', # Client-Error 400 => 'Bad Request', 401 => 'Unauthorized', 402 => 'Payment Required', 403 => 'Forbidden', 404 => 'Not Found', 405 => 'Method Not Allowed', 406 => 'Not Acceptable', 407 => 'Proxy Authentication Required', 408 => 'Request Timeout', 410 => 'Gone', 413 => 'Request Entity Too Large', 414 => 'Request-URI Too Large', 415 => 'Unsupported Media Type', 416 => 'Unsupported URI Scheme', 420 => 'Bad Extension', 421 => 'Extension Required', 423 => 'Interval Too Brief', 480 => 'Temporarily not available', 481 => 'Call Leg/Transaction Does Not Exist', 482 => 'Loop Detected', 483 => 'Too Many Hops', 484 => 'Address Incomplete', 485 => 'Ambiguous', 486 => 'Busy Here', 487 => 'Request Terminated', 488 => 'Not Acceptable Here', 491 => 'Request Pending', 493 => 'Undecipherable', # Server-Error 500 => 'Internal Server Error', 501 => 'Not Implemented', 502 => 'Bad Gateway', 503 => 'Service Unavailable', 504 => 'Server Time-out', 505 => 'SIP Version not supported', 513 => 'Message Too Large', # Global-Failure 600 => 'Busy Everywhere', 603 => 'Decline', 604 => 'Does not exist anywhere', 606 => 'Not Acceptable', ); ########################################################################### # Redefine methods from Net::SIP::Packet, no need to find out dynamically ########################################################################### sub is_request {1} sub is_response {0} ########################################################################### # Accessors for method and URI ########################################################################### sub method { return (shift->as_parts())[0] } sub uri { return (shift->as_parts())[1] } sub set_uri { my Net::SIP::Request $self = shift; $self->_update_string; $self->{text} = shift; } ########################################################################### # set cseq # Args: ($self,$number) # $number: new cseq number # Returns: $self ########################################################################### sub set_cseq { my Net::SIP::Request $self = shift; my $cseq = shift; $self->set_header( cseq => "$cseq ".$self->method ); return $self; } ########################################################################### # create ack to response based on original request # see RFC3261 "17.1.1.3 Construction of the ACK Request" # Args: ($self,$response) # $response: Net::SIP::Response object for request $self # Returns: $cancel # $ack: Net::SIP::Request object for ACK method ########################################################################### sub create_ack { my Net::SIP::Request $self = shift; my $response = shift; # ACK uses cseq from request $self->cseq =~m{(\d+)}; my $cseq = "$1 ACK"; my %auth; for (qw(authorization proxy-authorization)) { my $v = scalar($self->get_header($_)) or next; $auth{$_} = $v; } my $header = { 'call-id' => scalar($self->get_header('call-id')), from => scalar($self->get_header('from')), # unlike CANCEL the 'to' header is from the response to => [ $response->get_header('to') ], via => [ ($self->get_header( 'via' ))[0] ], route => [ $self->get_header( 'route' ) ], cseq => $cseq, %auth, }; return Net::SIP::Request->new( 'ACK',$self->uri,$header ); } ########################################################################### # Create cancel for request # Args: $self # Returns: $cancel # $cancel: Net::SIP::Request containing CANCEL for $self ########################################################################### sub create_cancel { my Net::SIP::Request $self = shift; # CANCEL uses cseq from request $self->cseq =~m{(\d+)}; my $cseq = "$1 CANCEL"; my %auth; for (qw(authorization proxy-authorization)) { my $v = scalar($self->get_header($_)) or next; $auth{$_} = $v; } my $header = { 'call-id' => scalar($self->get_header('call-id')), from => scalar($self->get_header('from')), # unlike ACK the 'to' header is from the original request to => [ $self->get_header('to') ], via => [ ($self->get_header( 'via' ))[0] ], route => [ $self->get_header( 'route' ) ], cseq => $cseq, %auth }; return Net::SIP::Request->new( 'CANCEL',$self->uri,$header ); } ########################################################################### # Create response to request # Args: ($self,$code,[$msg],[$args,$body]) # $code: numerical response code # $msg: msg for code, if arg not given it will be used from %ResponseCode # $args: additional args for SIP header # $body: body as string # Returns: $response # $response: Net::SIP::Response ########################################################################### sub create_response { my Net::SIP::Request $self = shift; my $code = shift; my ($msg,$args,$body) = ( defined $_[0] && ref($_[0]) ) ? (undef,@_):@_; $msg = $ResponseCode{$code} if ! defined $msg; my %header = ( cseq => scalar($self->get_header('cseq')), 'call-id' => scalar($self->get_header('call-id')), from => scalar($self->get_header('from')), to => [ $self->get_header('to') ], 'record-route' => [ $self->get_header( 'record-route' ) ], via => [ $self->get_header( 'via' ) ], $args ? %$args : () ); return Net::SIP::Response->new($code,$msg,\%header,$body); } ########################################################################### # Authorize Request based on credentials in response using # Digest Authorization specified in RFC2617 # Args: ($self,$response,@args) # $response: Net::SIP::Response for $self which has code 401 or 407 # @args: either [ $user,$pass ] if there is one user+pass for all realms # or { realm1 => [ $user,$pass ], realm2 => [...].. } # for different user,pass in different realms # or callback(realm)->[ user,pass ] # Returns: 0|1 # 1: if (proxy-)=authorization headers were added to $self # 0: if $self was not modified, e.g. no usable authenticate # headers were found ########################################################################### sub authorize { my Net::SIP::Request $self = shift; my ($response,$user2pass) = @_; # find out format of user2pass my ($default_upw,$realm2upw,$cb_upw); if ( ref($user2pass) eq 'ARRAY' && ! ref( $user2pass->[0] )) { $default_upw = $user2pass; } elsif ( ref($user2pass) eq 'HASH' ) { $realm2upw = %$user2pass; } else { $cb_upw = $user2pass; } my $auth = 0; my %auth_map = ( 'proxy-authenticate' => 'proxy-authorization', 'www-authenticate' => 'authorization', ); while ( my ($req,$resp) = each %auth_map ) { my $existing_auth; if ( my @auth = $response->get_header_hashval( $req ) ) { foreach my $a (@auth) { my $h = $a->{parameter}; # check if we already have an authorize header for this realm/opaque if ( ! $existing_auth ) { $existing_auth = {}; foreach my $hdr ( $self->get_header_hashval( $resp )) { my @auth = grep { defined } map { $hdr->{parameter}{$_} }qw( realm opaque ); $existing_auth->{ join( "\0",@auth ) } = 1; } } my @auth = grep { defined } map { $h->{$_} }qw( realm opaque ); if ( $existing_auth->{ join( "\0",@auth ) } ) { # we have this auth header already, don't repeat next; } # RFC2617 # we support only md5 (not md5-sess or other) # and only empty qop or qop=auth (not auth-int or other) if ( lc($a->{data}) ne 'digest' || $h->{algorithm} && lc($h->{algorithm}) ne 'md5' || $h->{qop} && $h->{qop} !~ m{(?:^|,\s*)auth(?:$|,)}i ) { no warnings; DEBUG(10,"unsupported authorization method $a->{data} method=$h->{method} qop=$h->{qop}"); next; } my $realm = $h->{realm}; my $upw = $cb_upw ? invoke_callback( $cb_upw, $realm ) : $realm2upw ? $realm2upw->{$realm} : $default_upw ? $default_upw : next; # for meaning of a1,a2... and for the full algorithm see RFC2617, 3.2.2 my $a1 = join(':',$upw->[0],$realm,$upw->[1] ); # 3.2.2.2 my $a2 = join(':',$self->method,$self->uri ); # 3.2.2.3, qop == auth|undef my %digest = ( username => $upw->[0], realm => $realm, nonce => $h->{nonce}, uri => $self->uri, ); $digest{opaque} = $h->{opaque} if defined $h->{opaque}; # 3.2.2.1 if ( $h->{qop} ) { $h->{qop} = 'auth'; # in case it was 'auth,auth-int' my $nc = $digest{nc} = '00000001'; my $cnonce = $digest{cnonce} = sprintf("%08x",rand(2**32)); $digest{qop} = $h->{qop}; $digest{response} = md5_hex( join(':', md5_hex($a1), $h->{nonce}, $nc, $cnonce, $h->{qop}, md5_hex($a2) )); } else { # 3.2.2.1 compability with RFC2069 $digest{response} = md5_hex( join(':', md5_hex($a1), $h->{nonce}, md5_hex($a2), )); } # RFC2617 has it's specific ideas what should be quoted and what not # so we assemble it manually my $header = qq[Digest username="$digest{username}",realm="$digest{realm}",]. qq[nonce="$digest{nonce}",uri="$digest{uri}",response="$digest{response}"]; $header.= qq[,opaque="$digest{opaque}"] if defined $digest{opaque}; $header.= qq[,cnonce="$digest{cnonce}"] if defined $digest{cnonce}; $header.= qq[,qop=$digest{qop}] if defined $digest{qop}; $header.= qq[,nc=$digest{nc}] if defined $digest{nc}; # Echo back the algorithm if specifically set in response $header.= qq[,algorithm=$h->{algorithm}] if defined $h->{algorithm}; $self->add_header( $resp, $header ); $auth++; } } } return if !$auth; # no usable authenticate headers found my ($rseq) = $response->cseq =~m{^(\d+)}; $self->cseq =~m{^(\d+)(.*)}; if ( defined $1 and $1 <= $rseq ) { # increase cseq, because this will be a new request, not a retransmit $self->set_header( cseq => ($rseq+1).$2 ); } return 1; } 1; Net-SIP-0.822/lib/Net/SIP/Dispatcher.pm0000644000175100017510000012027713223634244016023 0ustar workwork ########################################################################### # 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 'dnsresolv', # optional external DNS resolver ); use Net::SIP::Leg; use Net::SIP::Util ':all'; use Net::SIP::Dispatcher::Eventloop; use Errno qw(EHOSTUNREACH ETIMEDOUT ENOPROTOOPT); use IO::Socket; use List::Util 'first'; use Hash::Util 'lock_ref_keys'; use Carp 'croak'; use Net::SIP::Debug; use Scalar::Util 'weaken'; # The maximum priority value in SRV records is 0xffff and the lowest priority # value is considered the best. Make undefined priority higher so that it gets # considered as last option. use constant SRV_PRIO_UNDEF => 0x10000; ########################################################################### # 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 hash with keys prio, proto, host, # port and family like in the DNS SRV record # with special domain '*' a default can be specified, so that DNS # will not be used at all # dnsresolv: DNS resolver function with interface sub->(type,domain,callback) # which then calls callback->(\@result) with @result being a list of # [ 'SRV',prio,target,port], ['A',ip,name], ['AAAA',ip,name] # Returns: $self ########################################################################### sub new { my ($class,$legs,$eventloop,%args) = @_; my ($outgoing_proxy,$do_retransmits,$domain2proxy,$dnsresolv) = delete @args{qw( outgoing_proxy do_retransmits domain2proxy dnsresolv)}; 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,?family ] } else { my ($proto,$host,$port,$family) = sip_uri2sockinfo($_) or croak( "invalid entry in domain2proxy: $_" ); $port ||= $proto && $proto eq 'tls' ? 5061:5060; $_ = [ map { lock_ref_keys({ prio => SRV_PRIO_UNDEF, proto => $_, host => $host, addr => $family ? $host : undef, port => $port, family => $family }) } $proto ? ($proto) : ('udp','tcp') ]; } } 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, dnsresolv => $dnsresolv, ); $self->add_leg( @$legs ); $self->outgoing_proxy($outgoing_proxy) if $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; } ########################################################################### # get or set outgoing proxy # Args: ($self;$proxy) # $proxy: optional new proxy or undef if proxy should be none # Returns: # $proxy: current setting, i.e. after possible update ########################################################################### sub outgoing_proxy { my Net::SIP::Dispatcher $self = shift; return $self->{outgoing_proxy} if ! @_; my $outgoing_proxy = shift; my $leg = $self->_find_leg4addr( $outgoing_proxy ) || die "cannot find leg for destination $outgoing_proxy"; $self->{outgoing_proxy} = $outgoing_proxy; } ########################################################################### # get or set the event loop # Args: ($self;$loop) # $loop: optional new loop # Returns: # $loop: current setting, i.e. after possible update ########################################################################### sub loop { my Net::SIP::Dispatcher $self = shift; return $self->{eventloop} if ! @_; $self->{eventloop} = shift; } ########################################################################### # 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 $socketpool = $leg->socketpool) { my $cb = sub { # don't crash Dispatcher on bad or unexpected packets eval { my ($self,$leg,$packet,$from) = @_; $self || return; ($packet,$from) = $leg->receive($packet,$from) or 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}); my ($host,$port) = $d =~m{^SIP/2\S+\s+(\S+)$} ? ip_string2parts($1):(); my %nh; if ( exists $h->{rport} and ! defined $h->{rport}) { $nh{rport} = $from->{port}; } if ($host ne $from->{addr}) { # either from.addr is the addr for host or we # had a different IP address in the via header $nh{received} = $from->{addr}; } elsif ($nh{rport}) { # required because rport was set $nh{received} = $from->{addr}; } if (%nh) { $hdr->{value} = sip_parts2hdrval('via',$d,{ %$h,%nh}); $hdr->set_modified; } }, \( my $cvia )]); } # handle received packet $self->receive( $packet,$leg,$from ); 1; } or DEBUG(1,"dispatcher croaked: $@"); }; $cb = [ $cb,$self,$leg ]; weaken($cb->[1]); weaken($cb->[2]); $socketpool->attach_eventloop($self->{eventloop}, $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 $pool = $leg->socketpool ) { $pool->attach_eventloop(); } } } ########################################################################### # 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 # 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} }) { push @rv,$leg if $leg->match(\%args); } return @rv; } ########################################################################### # map leg to index in list of legs # Args: @legs,[\$dict] # @legs: list of legs # $dict: string representation of dictionary, used in i2leg and others # to make sure that it the indices come from the same list of legs. # Will be set if given # Returns: @ilegs # @ilegs: index of each of @legs in dispatcher, -1 if not found ########################################################################### sub legs2i { my Net::SIP::Dispatcher $self = shift; my $legs = $self->{legs}; if (ref($_[-1]) eq 'SCALAR') { my $dict = pop @_; $$dict = join("|",map { $_->key } @$legs); } my @result; for(@_) { my $i; for($i=$#$legs;$i>=0;$i--) { last if $legs->[$i] == $_; } push @result,$i; } return @result; } ########################################################################### # map index to leg in list of legs # Args: @ilegs,[\$dict] # @ilegs: list of leg indices # $dict: optional string representation of dictionary, will return () # if $dict does not match current legs and order in dispatcher # Returns: @legs # @legs: list of legs matching indices ########################################################################### sub i2legs { my Net::SIP::Dispatcher $self = shift; my $legs = $self->{legs}; if (ref($_[-1])) { return if ${pop(@_)} ne join("|",map { $_->key } @$legs); } return @{$legs}[@_]; } ########################################################################### # 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 as hash with keys # proto,addr,port,family,host. 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: [proto,ip,from,family] # 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 ) { # completely 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}, ); } if ($qentry->{retransmits} && ! $leg->do_retransmits) { $qentry->{retransmits} = undef; } # 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 #Carp::confess("expected reference, got $dst_addr") if !ref($dst_addr); $DEBUG && DEBUG(50,"deliver through leg ".$leg->dump.' @' .ip_parts2string($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, tls). # 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,$param) = sip_uri2parts($uri); $domain or do { DEBUG( 50,"bad URI '$uri'" ); return invoke_callback($callback, EHOSTUNREACH ); }; my @proto; my $default_port = 5060; if ( $sip_proto eq 'sips' ) { $default_port = 5061; @proto = 'tls'; } 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" ); @$dst_addr = (); 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 = $param->{maddr}; { my ($host,$port,$family) = ip_string2parts($domain, $ip_addr ? 1:0); $default_port = $port if defined $port; if ($family) { $ip_addr ||= $host; $domain = ip_ptr($host,$family); } else { $domain = $host; } } 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_is_v46($ip); } # entries are hashes of prio,proto,host,addr,port,family my @resp; foreach my $addr ( @$dst_addr ) { if ( ref($addr)) { push @resp,$addr; # right format: see domain2proxy } else { my ($proto,$host,$port,$family) = sip_uri2sockinfo($addr) or next; $addr = lock_ref_keys({ proto => $proto, host => $host, addr => $family ? $host : undef, port => $port || $default_port, family => $family }); push @resp, map { lock_ref_keys({ %$addr, proto => $_, prio => SRV_PRIO_UNDEF, }) } $proto ? ($proto) : @proto; } } # should we use a fixed transport? if (@resp and my $proto = $param->{transport} ) { $proto = lc($proto); if ($proto eq 'udp') { @resp = grep { $_->{proto} eq 'udp' } @resp } elsif ($proto eq 'tcp') { # accept proto tcp and tls @resp = grep { $_->{proto} ne 'udp' } @resp } elsif ($proto eq 'tls') { @resp = grep { $_->{proto} eq 'tls' } @resp } else { # no matching proto available @resp = (); } return invoke_callback($callback, ENOPROTOOPT) if ! @resp; } my @param = ( $dst_addr,$legs,$allowed_legs,$default_port,$callback ); if (@resp) { # directly call __resolve_uri_final if all names are resolved return __resolve_uri_final( @param,\@resp ) if ! grep { ! $_->{addr} } @resp; return $self->dns_host2ip(\@resp, [ \&__resolve_uri_final, @param ]); } # 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, [ \&__resolve_uri_final, @param ]); } sub __resolve_uri_final { my ($dst_addr,$legs,$allowed_legs,$default_port,$callback,$resp) = @_; $DEBUG && DEBUG_DUMP( 100,$resp ); return invoke_callback( $callback,EHOSTUNREACH ) unless $resp && @$resp; # for A|AAAA records we got no port, use default_port $_->{port} ||= $default_port for(@$resp); # sort by prio # FIXME: can contradict order in @proto @$resp = sort { $a->{prio} <=> $b->{prio} } @$resp; @$dst_addr = (); @$legs = (); foreach my $r ( @$resp ) { my $leg = first { $_->can_deliver_to( proto => $r->{proto}, host => $r->{host}, addr => $r->{addr}, port => $r->{port}, family => $r->{family}, )} @$allowed_legs; if ( $leg ) { push @$dst_addr, $r; push @$legs,$leg; } else { DEBUG(50,"no leg with $r->{proto} to %s", ip_parts2string($r)); } } return invoke_callback( $callback, EHOSTUNREACH ) if !@$dst_addr; invoke_callback( $callback ); } sub _find_leg4addr { my Net::SIP::Dispatcher $self = shift; my $dst_addr = shift; if (!ref($dst_addr)) { my @si = sip_uri2sockinfo($dst_addr); $dst_addr = lock_ref_keys({ proto => $si[0], host => $si[1], addr => $si[3] ? $si[1] : undef, port => $si[2], family => $si[3], }); } return grep { $_->can_deliver_to(%$dst_addr) } @{ $self->{legs} }; } ########################################################################### # resolve hostname to IP using DNS # Args: ($self,$host,$callback) # $host: hostname or hash with hostname as keys or list of hashes which have # a host value but miss an addr value # $callback: gets called with (result)|() once finished # result is @IP for single hosts or the input hash ref where the # IPs are filled in as values or the list filled with addr, family # Returns: NONE ########################################################################### sub dns_host2ip { my Net::SIP::Dispatcher $self = shift; my ($host,$callback) = @_; my (@rec,$cb); if (!ref($host)) { # scalar: return ip(s) @rec = { host => $host }; my $transform = sub { my ($callback,$res) = @_; invoke_callback($callback, grep { $_ } map { $_->{addr} } @$res); }; $cb = [ $transform, $callback ]; } elsif (ref($host) eq 'HASH') { # hash: fill hash values @rec = map { (host => $_) } keys(%$host); return invoke_callback($callback, $host) if ! @rec; my $transform = sub { my ($host,$callback,$res) = @_; $host->{$_->{host}} = $_->{addr} for @$res; invoke_callback($callback, $host); }; $cb = [ $transform, $host, $callback ]; } else { # list of hashes: fill in addr and family in place my @hasip; for(@$host) { if ($_->{addr}) { push @hasip, $_; } else { push @rec, $_; } } return invoke_callback($callback, $host) if ! @rec; my $transform = sub { my ($hasip,$callback,$res) = @_; # original order might be changed !!! push @$res, @$hasip; invoke_callback($callback, $res); }; $cb = [ $transform, \@hasip, $callback ]; } my @queries; for (@rec) { my %q = (name => $_->{host}, rec => $_); push @queries, { type => 'AAAA', %q } if CAN_IPV6; push @queries, { type => 'A', %q }; } my $res = $self->{dnsresolv} || __net_dns_resolver($self->{eventloop}); __generic_resolver({ queries => \@queries, callback => $cb, resolver => $res, }); } ########################################################################### # get SRV records using DNS # Args: ($self,$domain,$proto,$sip_proto,$callback) # $domain: domain for SRV query # $proto: which protocols to check: list of udp|tcp|tls # $callback: gets called with result once finished # result is \@list of hashes with prio, proto, host ,port, family # Returns: NONE ########################################################################### sub dns_domain2srv { my Net::SIP::Dispatcher $self = shift; my ($domain,$protos,$callback) = @_; # Try to get SRV records for _sip._udp.domain or _sip._tcp.domain my @queries; for(@$protos) { push @queries, { type => 'SRV', name => $_ eq 'tls' ? "_sips._tcp.$domain" : "_sip._$_.$domain", rec => { host => $domain, proto => $_ }, } } # If we have any results for SRV we can break, # otherwise continue with with A|AAAA push @queries, { type => 'BREAK-IF-RESULTS' }; for(@$protos) { my %r = ( name => $domain, rec => { prio => SRV_PRIO_UNDEF, host => $domain, proto => $_, port => undef, } ); push @queries, { type => 'AAAA', %r } if CAN_IPV6; push @queries, { type => 'A', %r }; } my $res = $self->{dnsresolv} || __net_dns_resolver($self->{eventloop}); __generic_resolver({ queries => \@queries, callback => $callback, resolver => $res, }); } # generic internal resolver helper # expects to be initially called as # __generic_resolver({ # queries => \@queries, # callback => $callback, # resolver => $res, # }); # # where queries are a list of tasks for DNS lookup with # type: SRV|A|AAAA # name: the name to lookup # rec: the record to enrich with # SRV: prio, proto, host, addr, port, family # A|AAAA: addr, family # # resolver is a function to do the actual resolving. # An implementation using Net::DNS is done in __net_dns_resolver. # It will be called as # resolver->(type,name,callback) where # type: SRV|A|AAAA # name: the name to lookup # callback: callback to invoke after lookup is done with the list of # answers, i.e. list-ref containing # [ 'SRV', prio, proto, host, port ] # [ 'A', addr, name ] # [ 'AAAA', addr, name ] # # callback is invoked when all queries are done with the list of # enriched records sub __generic_resolver { my ($state,$qid,$ans) = @_; $DEBUG && DEBUG_DUMP(100,[$qid,$ans]) if $qid; my $queries = $state->{queries}; my $results = $state->{results} ||= []; goto after_answers if !$qid; for(my $i=0; $i<@$queries; $i++) { my $q = $queries->[$i]; if ($q->{type} eq 'BREAK-IF-RESULTS') { if (@$results) { # skip remaining queries @$queries = (); last; } if ($i==0) { # remove if top query shift(@$queries); $i--; } next; } "$q->{type}:$q->{name}" eq $qid or next; # query matches qid of answer, remove from @$queries splice(@$queries,$i,1); $i--; if ($q->{type} eq 'SRV') { my (%addr2ip,@res); for(@$ans) { my $type = shift(@$_); if ($type eq 'A' or CAN_IPV6 ? $type eq 'AAAA' : 0) { # supplemental data my ($ip,$name) = @_; push @{ $addr2ip{$name}}, [$ip, $type]; next; } next if $type ne 'SRV'; my ($prio,$host,$port) = @$_; my $family = ip_is_v46($host); push @res, lock_ref_keys({ %{$q->{rec}}, prio => $prio, host => $host, addr => $family ? $host : undef, port => $port, family => $family, }); } for(my $i=0; $i<@res; $i++) { $res[$i]{family} and next; my $ipt = $addr2ip{$res[$i]{host}} or next; my $r = splice(@res,$i,1); for(@$ipt) { my ($ip,$type) = @$_; splice(@res,$i,0, lock_ref_keys({ %$r, addr => $ip, family => $type eq 'A' ? AF_INET : AF_INET6, })); $i++; } $i--; } for my $r (@res) { if ($_->{family}) { # done: host in SRV record is already IP address push @$results, $r; next; } # need to resolve host in SRV record - put queries on top for my $type (CAN_IPV6 ? qw(AAAA A) : qw(A)) { unshift @$queries, { type => $type, name => $r->{host}, rec => lock_ref_keys({ %$r, family => $type eq 'A' ? AF_INET : AF_INET6, }) }; } } } elsif ($q->{type} eq 'AAAA' || $q->{type} eq 'A') { for(@$ans) { my ($type,$ip) = @$_; push @$results, lock_ref_keys({ %{$q->{rec}}, addr => $ip, family => $type eq 'A' ? AF_INET : AF_INET6, }); } } else { die "unknown type $q->{type}"; } } after_answers: if (!@$queries) { # no more queries -> done invoke_callback($state->{callback}, @$results && $results); return; } # still queries -> send next to resolver my $q = $queries->[0]; DEBUG(52,'issue lookup for %s %s',$q->{type}, $q->{name}); $state->{resolver}($q->{type}, $q->{name}, [ \&__generic_resolver, $state, "$q->{type}:$q->{name}" ]); } my $NetDNSResolver; sub __net_dns_resolver { my $eventloop = shift; # Create only a single resolver. $NetDNSResolver ||= eval { require Net::DNS; Net::DNS->VERSION >= 0.56 or die "version too old, need 0.56+"; Net::DNS::Resolver->new; } || die "cannot create resolver: Net::DNS not available?: $@"; my $dnsread = sub { my ($sock,$callback) = @_; my $q = $NetDNSResolver->bgread($sock); $eventloop->delFD($sock); my @ans; for my $rr ( $q->answer ) { if ($rr->type eq 'SRV' ) { push @ans, [ 'SRV', $rr->priority, $rr->target, $rr->port, ]; } elsif ($rr->type eq 'A' || $rr->type eq 'AAAA') { push @ans, [ $rr->type, $rr->address, $rr->name ]; } } invoke_callback($callback,\@ans); }; return sub { my ($type,$name,$callback) = @_; my $sock = $NetDNSResolver->bgsend($name,$type); $eventloop->addFD($sock, EV_READ, [$dnsread, $sock, $callback], 'dns' ); }; } ########################################################################### # 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: # [ { hash: proto, addr, port, family, host }, { ... }, ...] '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 ':all'; use Hash::Util 'lock_ref_keys'; ########################################################################### # 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; my $addr = $self->{dst_addr}; if (!$addr) { } elsif (!ref($addr)) { my @si = sip_uri2sockinfo($addr); $self->{dst_addr} = [ lock_ref_keys({ proto => $si[0], host => $si[1], addr => $si[3] ? $si[1] : undef, port => $si[2], family => $si[3], }) ]; } elsif (ref($addr) eq 'HASH') { $self->{dst_addr} = [ $addr ]; } else { # assume its already in the expected format, i.e. list of hashes } if ( my $leg = $self->{leg} ) { $self->{leg} = [ $leg ] if UNIVERSAL::can( $leg,'deliver' ); } $self->{dst_addr} ||= []; $self->{leg} ||= []; 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; return if $self->{leg}[0] && ! $self->{leg}[0]->do_retransmits; 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; Net-SIP-0.822/lib/Net/SIP/SocketPool.pm0000644000175100017510000005267013142272502016013 0ustar workwork# Collection of sockets associated with a Leg: # This gets attached to an IO-Loop so that a common callback will be called with # (packet,from) which then can be processed by the Leg and Dispatcher. # Sending through the SocketPool is done by automatically selecting or creating # the appropriate socket based on target and/or packet->tid. use strict; use warnings; package Net::SIP::SocketPool; use fields qw(loop ipproto tls dst fds tids cb timeout_timer); use Net::SIP::Util ':all'; use Net::SIP::Packet; use Net::SIP::Debug; use Net::SIP::Dispatcher::Eventloop; use Socket qw(SOL_SOCKET SO_ERROR); # RFC does not specify some fixed limit for the SIP header and body so we have # to make up some limits we think are useful. my $MAX_SIP_HEADER = 2**14; # 16k header my $MAX_SIP_BODY = 2**16; # 64k body # how many requests we can associate with a socket at the same time my $MAX_TIDLIST = 30; my $MIN_EXPIRE = 15; # wait at least this time before closing on inactivity my $MAX_EXPIRE = 120; # wait at most this time my $CONNECT_TIMEOUT = 10; # max time for TCP connect my $TCP_READSIZE = 2**16; # size of TCP read sub import { my %m = ( MAX_SIP_HEADER => \$MAX_SIP_HEADER, MAX_SIP_BODY => \$MAX_SIP_BODY, MAX_TIDLIST => \$MAX_TIDLIST, MIN_EXPIRE => \$MIN_EXPIRE, MAX_EXPIRE => \$MAX_EXPIRE, CONNECT_TIMEOUT => \$CONNECT_TIMEOUT, TCP_READSIZE => \$TCP_READSIZE, ); for(my $i=1;$i<@_;$i+=2) { my $ref = $m{$_[$i]} or die "no such config key '$_[$i]'"; $$ref = $_[$i+1]; } } my %TLSClientDefault = (SSL_verifycn_scheme => 'sip'); my %TLSServerDefault = (); # will be defined on first use of SSL depending if IO::Socket::SSL is available my $CAN_TLS; my $SSL_REUSE_CTX; my ($SSL_WANT_READ, $SSL_WANT_WRITE, $SSL_VERIFY_PEER, $SSL_VERIFY_FAIL_IF_NO_PEER_CERT); our $SSL_ERROR; ########################################################################### # create a new SocketPool # Args: ($class,$proto,$fd,$peer,$connected,$tls) # $proto: udp|tcp|tls # $fd: the file descriptor for the master socket (i.e. listener) # $peer: optional hash with addr,port,family of destination if restricted # $connected: true if $fd is connected to $peer (useful with UDP only) # $tls: \%options for IO::Socket::SSL when proto is tls # Returns: $self ########################################################################### sub new { my ($class,$proto,$fd,$peer,$connected,$tls) = @_; my $self = fields::new($class); if ($proto eq 'tls') { # the underlying proto is still TCP and we remember to use TLS by # having a true self.tls $self->{ipproto} = 'tcp'; $CAN_TLS //= eval "use IO::Socket::SSL;1" && eval { # 1.956 defines the 'sip' scheme for hostname validation IO::Socket::SSL->VERSION >= 1.956 or die "need at least version 1.956"; $SSL_WANT_READ = IO::Socket::SSL::SSL_WANT_READ(); $SSL_WANT_WRITE = IO::Socket::SSL::SSL_WANT_WRITE(); $SSL_VERIFY_PEER = IO::Socket::SSL::SSL_VERIFY_PEER(); $SSL_VERIFY_FAIL_IF_NO_PEER_CERT = IO::Socket::SSL::SSL_VERIFY_FAIL_IF_NO_PEER_CERT(); *SSL_ERROR = \$IO::Socket::SSL::SSL_ERROR; # 1.969 fixed name validation when reusing context $SSL_REUSE_CTX = IO::Socket::SSL->VERSION >= 1.969; 1; } || die "no SSL support using IO::Socket::SSL: $@"; # create different contexts for [m]aster and [c]lient $tls ||= {}; my $verify_client = delete $tls->{verify_client}; $self->{tls}{c} = { %TLSClientDefault, %$tls }; $self->{tls}{m} = { %TLSServerDefault, %$tls, SSL_server => 1, # request client certificate? ! $verify_client ? (): $verify_client == -1 ? (SSL_verify_mode => $SSL_VERIFY_PEER) : $verify_client == 1 ? (SSL_verify_mode => $SSL_VERIFY_PEER|$SSL_VERIFY_FAIL_IF_NO_PEER_CERT) : die "invalid setting for SSL_verify_client: $verify_client" }; if ($SSL_REUSE_CTX) { for(qw(m c)) { $self->{tls}{$_}{SSL_reuse_ctx} and next; my $ctx = IO::Socket::SSL::SSL_Context->new($self->{tls}{$_}) || die "failed to create SSL context: $SSL_ERROR"; $self->{tls}{$_}{SSL_reuse_ctx} = $ctx; } } } else { $self->{ipproto} = $proto || die "no protocol given"; } $self->{fds} = {}; $self->{tids} = {}; if (!$connected) { $self->{dst} = $peer; $peer = undef; } _add_socket($self,{ fd => $fd, $peer ? (peer => $peer) : (), master => 1, }); return $self; } sub DESTROY { my Net::SIP::SocketPool $self = shift; # detach from current loop if ($self->{loop}) { for(values %{$self->{fds}}) { $self->{loop}->delFD($_->{fd} || next); } } } ########################################################################### # attaches SocketPool to EventLoop # Args: ($self,$loop,$callback) # $loop: Net::SIP::Dispatcher::Eventloop or API compatible # $callback: should be called for each new SIP packet received # Comment: # If $loop is empty it just detaches from the current loop ########################################################################### sub attach_eventloop { my Net::SIP::SocketPool $self = shift; my ($loop,$cb) = @_; if ($self->{loop}) { for(values %{$self->{fds}}) { $self->{loop}->delFD($_->{fd}); } if ($self->{timeout_timer}) { $self->{timeout_timer}->cancel; undef $self->{timeout_timer}; } } if ($self->{loop} = $loop) { $self->{cb} = $cb; _addreader2loop($self,$_) for values %{$self->{fds}}; } } ########################################################################### # returns master socket # Args: $self # Returns: $fd # $fd: master socket ########################################################################### sub master { my Net::SIP::SocketPool $self = shift; my @fo = grep { $_->{master} } values %{$self->{fds}}; die "no master" if ! @fo; die "multiple master" if @fo>1; return $fo[0]{fd}; } ########################################################################### # send packet via SocketPool # Args: ($self,$packet,$dst,$callback) # $packet: Net::SIP::Packet # $dst: where to send as hash with addr,port,family # $callback: callback to call on definite successful delivery (TCP/TLS only) # or on error ########################################################################### sub sendto { my Net::SIP::SocketPool $self = shift; my ($packet,$dst,$callback) = @_; if ($self->{dst}) { $dst = $self->{dst}; # override destination } elsif (!ref($dst)) { $dst = ip_string2parts($dst); } # select all sockets which are connected to the target # if we have multiple connected reduce further by packets tid # take one socket my $fos = [ values %{$self->{fds}} ]; if (@$fos>1) { my $match = 0; # any socket associated with tid? if ($packet->is_response and my $fo = $self->{tids}{$packet->tid}) { if (my @s = grep { $_ == $fo } @$fos) { $match |= 1; $fos = \@s } } if (@$fos>1) { # any socket connected to dst? if ( my @s = grep { $_->{peer} && $_->{peer}{addr} eq $dst->{addr} && $_->{peer}{port} == $dst->{port} } @$fos) { $match |= 2; $fos = \@s; } } if (!$match) { # use master $fos = [ grep { $_->{master} } @$fos ]; } } my $fo = $fos->[0]; my $data = $packet->as_string; if ($self->{ipproto} eq 'udp') { if ($fo->{peer}) { # send over connected UDP socket my $rv = send($fo->{fd},$data,0); invoke_callback($callback, $!) if ! defined($rv); return; } else { # sendto over unconnected UDP socket my $rv = send($fo->{fd},$data,0, ip_parts2sockaddr($dst)); invoke_callback($callback, $!) if ! defined($rv); return; } } if ($self->{ipproto} eq 'tcp') { if ($fo->{peer}) { $DEBUG && DEBUG(40,"send tcp data to %s via %s", ip_parts2string($dst), ip_parts2string($fo->{peer})); # send over this connected socket $fo->{wbuf} .= $data; _tcp_send($self,$fo,$callback) if ! $fo->{inside_connect}; return; } # TCP listener: we need to create a new connected socket first $DEBUG && DEBUG(40,"need new tcp socket to %s", ip_parts2string($dst)); my $clfd = INETSOCK( Proto => 'tcp', Reuse => 1, ReuseAddr => 1, LocalAddr => (ip_sockaddr2parts(getsockname($fo->{fd})))[0], Blocking => 0, ); $fo = $self->_add_socket({ fd => $clfd, peer => $dst, rbuf => '', wbuf => $data, didit => $self->{loop}->looptime, inside_connect => 1, }); _tcp_connect($self,$fo,ip_parts2sockaddr($dst),$callback); return; } die "unknown type $self->{ipproto}"; } sub _add_socket { my Net::SIP::SocketPool $self = shift; my $fo = shift; $fo->{fd}->blocking(0); $self->{fds}{ fileno($fo->{fd}) } = $fo; _addreader2loop($self,$fo) if $self->{loop} && ! $fo->{inside_connect}; $self->_timeout_sockets if ! $self->{timeout_timer} && $fo->{didit}; return $fo; } sub _del_socket { my Net::SIP::SocketPool $self = shift; my $fo = shift; $self->_error(@_) if @_; $self->{loop}->delFD($fo->{fd}) if $self->{loop}; delete $self->{fds}{ fileno($fo->{fd}) }; if ($fo->{tids}) { delete $self->{tids}{$_} for @{$fo->{tids}}; } return; } sub _timeout_sockets { my Net::SIP::SocketPool $self = shift; my $fds = $self->{fds}; goto disable_timer if keys(%$fds) <= 1; return if ! $self->{loop}; DEBUG(99,"timeout sockets"); # the more sockets we have open the faster expire my $expire = $MIN_EXPIRE + ($MAX_EXPIRE - $MIN_EXPIRE)/(keys(%$fds)-1); my ($time,$need_timer); for (values %$fds) { my $tdiff = -($_->{didit} || next) + ($time||= $self->{loop}->looptime); if ($tdiff>$expire) { $self->_del_socket($_); } elsif ($_->{inside_connect} && $tdiff > $CONNECT_TIMEOUT) { $self->_del_socket($_,"connect timed out"); } else { $need_timer = 1; } } if ($need_timer) { return if $self->{timeout_timer}; DEBUG(99,"timeout sockets - need timer"); $self->{timeout_timer} = $self->{loop}->add_timer( int($MIN_EXPIRE/2)+1, [ \&_timeout_sockets, $self ], int($MIN_EXPIRE/2)+1, 'socketpool-timeout' ); return; } disable_timer: DEBUG(99,"timer cancel"); ($self->{timeout_timer} || return)->cancel; undef $self->{timeout_timer}; } sub _error { my Net::SIP::SocketPool $self = shift; my $msg = shift; $msg = sprintf($msg,@_) if @_; DEBUG(1,$msg); return; } { my %type2cb = ( # unconnected UDP socket: receive and send udp_m => sub { my Net::SIP::SocketPool $self = shift; return $self->{dst} ? sub { _handle_read_udp(@_,1) } : sub { _handle_read_udp(@_) } }, # connected UDP socket: receive and send with fixed peer udp_co => sub { return \&_handle_read_udp }, # unconnected TCP socket: listen, accept and create tcp_co tcp_m => sub { return \&_handle_read_tcp_m }, # connected TCP socket: receive and send with fixed peer tcp_co => sub { my (undef,$fd) = @_; my $from = getpeername($fd); return sub { _handle_read_tcp_co(@_,$from) } } ); sub _addreader2loop { my Net::SIP::SocketPool $self = shift; my $fo = shift; # proto_co: connected socket, proto_m: (unconnected) master socket my $type = $self->{ipproto} . ($fo->{peer} ? '_co':'_m'); $self->{loop}->addFD($fo->{fd}, EV_READ, [ $type2cb{$type}($self,$fo->{fd}), $self ]); } } sub _check_from { my Net::SIP::SocketPool $self = shift; my $dst = $self->{dst} or return; my ($ip,$port) = ip_sockaddr2parts(shift()); if ($ip ne $dst->{addr} or $port ne $dst->{port}) { $DEBUG && DEBUG(1, "drop packet received from %s since expecting only from %s", ip_parts2string($ip,$port), ip_parts2string($dst) ); return 0; } return 1; } sub _handle_read_udp { my Net::SIP::SocketPool $self = shift; my $fd = shift; my $fo = $self->{fds}{ fileno($fd) } or die; my $from = recv($fd, my $buf, 2**16, 0) or return; # packet must be at least 13 bytes big (first line incl version # + final crlf crlf). Ignore anything smaller, probably keep-alives if ( length($buf)<13 ) { DEBUG(11,"ignored packet with len ".length($buf)." because to small (keep-alive?)"); return; } # check dst on unconnected UDP sockets shift() && ! _check_from($self,$from) && return; my $pkt = eval { Net::SIP::Packet->new_from_string($buf) } or return $self->_error( "drop invalid packet received from %s: %s", ip_sockaddr2string($from), $@ ); invoke_callback($self->{cb},$pkt, { %{ ip_sockaddr2parts($from) }, proto => 'udp', socket => $fd, }); } # read from unconnected TCP socket: # - accept new connection # - check against dst # - setup new connection to receive data sub _handle_read_tcp_m { my Net::SIP::SocketPool $self = shift; my $srvfd = shift; my $srvfo = $self->{fds}{ fileno($srvfd) } or die; my $from = accept(my $clfd, $srvfd) or return; $self->{dst} && ! _check_from($self,$from) && return; my $clfo = $self->_add_socket({ fd => $clfd, peer => scalar(ip_sockaddr2parts($from)), rbuf => '', wbuf => '', didit => $self->{loop}->looptime, inside_connect => $self->{tls} && 1, }); _tls_accept($self,$clfo) if $self->{tls}; } # read from connected TCP socket: # Since TCP is a stream SIP messages might be split over multiple reads or # a single read might contain more than one message. sub _handle_read_tcp_co { my Net::SIP::SocketPool $self = shift; my ($fd,$from) = @_; my $fo = $self->{fds}{ fileno($fd) } or die "no fd for read"; $DEBUG && $fo->{rbuf} ne '' && DEBUG(20, "continue reading SIP packet, offset=%d",length($fo->{rbuf})); retry: my $n = sysread($fd, $fo->{rbuf}, # read max size of TLS frame when tls so that we don't get any awkward # effects with user space buffering in TLS stack and select(2) $self->{tls} ? 2**14 : $TCP_READSIZE, length($fo->{rbuf})); if (!defined $n) { goto retry if $!{EINTR}; return if $!{EAGAIN} || $!{EWOULDBLOCK}; return $self->_del_socket($fo, "error while reading from %s: %s", ip_sockaddr2string($from), $!); } if (!$n) { # peer closed return $self->_del_socket($fo); } process_packet: # ignore any leading \r\n according to RFC 3261 7.5 if ($fo->{rbuf} =~s{\A((?:\r\n)+)}{}) { $DEBUG && DEBUG(20,"skipped over newlines preceding packet, size=%d", length($1)); } my $hdrpos = index($fo->{rbuf},"\r\n\r\n"); if ($hdrpos<0 && length($fo->{rbuf}) > $MAX_SIP_HEADER or $hdrpos > $MAX_SIP_HEADER) { return $self->_del_socket($fo, "drop packet from %s since SIP header is too big", ip_sockaddr2string($from)); } if ($hdrpos<0) { $DEBUG && DEBUG(20,"need more data for SIP header"); return; } $hdrpos += 4; # after header my %clen = map { $_ => 1 } substr($fo->{rbuf},0,$hdrpos) =~m{\nContent-length:\s*(\d+)\s*\n}ig; if (!%clen) { return $self->_del_socket($fo, "drop invalid SIP packet from %s: missing content-length", ip_sockaddr2string($from)); } if (keys(%clen)>1) { return $self->_del_socket($fo, "drop invalid SIP packet from %s: conflicting content-length", ip_sockaddr2string($from)); } my $clen = (keys %clen)[0]; if ($clen > $MAX_SIP_BODY) { return $self->_del_socket($fo, "drop packet from %s since SIP body is too big: %d>%d", ip_sockaddr2string($from), $clen, $MAX_SIP_BODY); } if ($hdrpos + $clen > length($fo->{rbuf})) { $DEBUG && DEBUG(20,"need %d more bytes for SIP body", $hdrpos + $clen - length($fo->{rbuf})); return; } my $pkt = eval { Net::SIP::Packet->new_from_string(substr($fo->{rbuf},0,$hdrpos+$clen,'')) } or return $self->_del_socket($fo, "drop invalid packet received from %s: %s", ip_sockaddr2string($from), $@); if ($pkt->is_request) { # associate $pkt->tid with this socket my $tidlist = $fo->{tids} ||= []; push @$tidlist, $pkt->tid; while (@$tidlist > $MAX_TIDLIST) { my $tid = shift(@$tidlist); delete $self->{tids}{$tid}; } $self->{tids}{ $tidlist->[-1] } = $fo; } $fo->{didit} = $self->{loop}->looptime if $self->{loop}; invoke_callback($self->{cb},$pkt, { %{ ip_sockaddr2parts($from) }, proto => $self->{tls} ? 'tls' : 'tcp', socket => $fd, }); # continue with processing any remaining data in the buffer goto process_packet if $fo->{rbuf} ne ''; } sub _tcp_connect { my Net::SIP::SocketPool $self = shift; my ($fo,$peer,$callback,$xxfd) = @_; while (!$xxfd) { # direct call, no connect done yet $fo->{didit} = $self->{loop}->looptime; my $rv = connect($fo->{fd},$peer); $DEBUG && DEBUG(100,"tcp connect: ".($rv || $!)); if ($rv) { # successful connect return _tls_connect($self,$fo,$callback) if $self->{tls}; delete $fo->{inside_connect}; last; } next if $!{EINTR}; if ($!{EALREADY} || $!{EINPROGRESS}) { # insert write handler $DEBUG && DEBUG(100,"tcp connect: add write handler for async connect"); $self->{loop}->addFD($fo->{fd}, EV_WRITE, [ \&_tcp_connect, $self,$fo,$peer,$callback ]); return; } # connect permanently failed my $err = $!; $self->_del_socket($fo, "connect to ".ip_sockaddr2string($peer)." failed: $!"); invoke_callback($callback,$err); return; } if ($xxfd) { # we are called from loop and hopefully async connect was succesful: # use getsockopt to check my $err = getsockopt($xxfd, SOL_SOCKET, SO_ERROR); $err = $err ? unpack('i',$err) : $!; if ($err) { # connection failed $! = $err; $self->_del_socket($fo, "connect to ".ip_sockaddr2string($peer)." failed: $!"); invoke_callback($callback,$err); return; } # connect done: remove write handler $self->{loop}->delFD($xxfd, EV_WRITE); return _tls_connect($self,$fo,$callback) if $self->{tls}; delete $fo->{inside_connect}; } _addreader2loop($self,$fo); # if we have something to write continue in _tcp_send return _tcp_send($self,$fo,$callback) if $fo->{wbuf} ne ''; # otherwise signal success via callback invoke_callback($callback,0) } sub _tcp_send { my Net::SIP::SocketPool $self = shift; my ($fo,$callback,$xxfd) = @_; while ($fo->{wbuf} ne '') { $fo->{didit} = $self->{loop}->looptime; if (my $n = syswrite($fo->{fd},$fo->{wbuf})) { substr($fo->{wbuf},0,$n,''); next; } next if $!{EINTR}; if ($!{EAGAIN} || $!{EWOULDBLOCK}) { return if $xxfd; # called from loop: write handler already set up # insert write handler $self->{loop}->addFD($fo->{fd}, EV_WRITE, [ \&_tcp_send, $self,$fo,$callback ]); return; } # permanently failed to write my $err = $!; $self->_del_socket($fo, "write failed: $!"); invoke_callback($callback,$err); return; } # write done: remove write handler if we are called from loop $DEBUG && DEBUG(90,"everything has been sent"); $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd; # signal success via callback invoke_callback($callback,0) } sub _tls_accept { my Net::SIP::SocketPool $self = shift; my ($fo,$xxfd) = @_; if (!$xxfd) { $DEBUG && DEBUG(40,"upgrade to SSL server"); IO::Socket::SSL->start_SSL($fo->{fd}, %{$self->{tls}{m}}, SSL_startHandshake => 0, ) or die "upgrade to SSL socket failed: $SSL_ERROR"; } if ($fo->{fd}->accept_SSL()) { if ($DEBUG) { my $peer_cert = $fo->{fd}->peer_certificate; DEBUG(40,"TLS accept success, %s", $peer_cert ? "peer="._dump_certificate($peer_cert) : 'no peer certificate'); } delete $fo->{inside_connect}; $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd; _addreader2loop($self,$fo); return; } if ($SSL_ERROR == $SSL_WANT_READ) { $DEBUG && DEBUG(40,"TLS accept - want read"); $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd; $self->{loop}->addFD($fo->{fd}, EV_READ, [ \&_tls_accept, $self, $fo ]); } elsif ($SSL_ERROR == $SSL_WANT_WRITE) { $DEBUG && DEBUG(40,"TLS accept - want write"); $self->{loop}->delFD($xxfd, EV_READ) if $xxfd; $self->{loop}->addFD($fo->{fd}, EV_WRITE, [ \&_tls_accept, $self, $fo ]); } else { # permanent error _del_socket($self, $fo, "SSL accept failed: $SSL_ERROR"); } } sub _tls_connect { my Net::SIP::SocketPool $self = shift; my ($fo,$callback,$xxfd) = @_; if (!$xxfd) { $DEBUG && DEBUG(40,"upgrade to SSL client"); IO::Socket::SSL->start_SSL($fo->{fd}, %{$self->{tls}{c}}, SSL_startHandshake => 0, SSL_verifycn_name => $fo->{peer}{host}, SSL_hostname => $fo->{peer}{host}, ) or die "upgrade to SSL socket failed: $SSL_ERROR"; } if ($fo->{fd}->connect_SSL()) { $DEBUG && DEBUG(40,"TLS connect success peer cert=%s", _dump_certificate($fo->{fd}->peer_certificate)); delete $fo->{inside_connect}; $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd; _addreader2loop($self,$fo); return _tcp_send($self,$fo,$callback) if $fo->{wbuf} ne ''; invoke_callback($callback,0); return; } if ($SSL_ERROR == $SSL_WANT_READ) { $DEBUG && DEBUG(40,"TLS connect - want read"); $self->{loop}->delFD($xxfd, EV_WRITE) if $xxfd; $self->{loop}->addFD($fo->{fd}, EV_READ, [ \&_tls_connect, $self, $fo, $callback ]); } elsif ($SSL_ERROR == $SSL_WANT_WRITE) { $DEBUG && DEBUG(40,"TLS connect - want write"); $self->{loop}->delFD($xxfd, EV_READ) if $xxfd; $self->{loop}->addFD($fo->{fd}, EV_WRITE, [ \&_tls_connect, $self, $fo, $callback ]); } else { # permanent error _del_socket($self, $fo, "SSL connect failed: $SSL_ERROR"); } } sub _dump_certificate { my $cert = shift or return ''; my $issuer = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name($cert)); my $subject = Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($cert)); return "s:$subject i:$issuer"; } 1; Net-SIP-0.822/lib/Net/SIP/Registrar.pm0000644000175100017510000001504413014661004015662 0ustar workwork########################################################################### # package Net::SIP::Registrar # implements a simple Registrar # FIXME: store registry information in a more flat format, so that # user can give a tied hash for permanent storage. Or give an object # interface with a simple default implementation but a way for the # user to provide its own implementation ########################################################################### use strict; use warnings; package Net::SIP::Registrar; use fields qw( store max_expires min_expires dispatcher domains _last_timer ); use Net::SIP::Util ':all'; use Carp 'croak'; use Net::SIP::Debug; use List::Util 'first'; ########################################################################### # creates new registrar # Args: ($class,%args) # %args # max_expires: maximum time for expire, default 300 # min_expires: manimum time for expire, default 30 # dispatcher: Net::SIP::Dispatcher object # domains: domain or \@list of domains the registrar is responsable # for, if not given it cares about everything # domain: like domains if only one domain is given # Returns: $self ########################################################################### sub new { my $class = shift; my %args = @_; my $domains = delete $args{domains} || delete $args{domain}; $domains = [ $domains ] if $domains && !ref($domains); my $self = fields::new($class); %$self = %args; $self->{max_expires} ||= 300; $self->{min_expires} ||= 30; $self->{dispatcher} or croak( "no dispatcher given" ); $self->{store} = {}; $self->{domains} = $domains; return $self; } # hack to have access to the store, to dump or restore it sub _store { my $self = shift; $self->{store} = shift if @_; return $self->{store}; } ########################################################################### # handle packet, called from Net::SIP::Dispatcher on incoming requests # Args: ($self,$packet,$leg,$addr) # $packet: Net::SIP::Request # $leg: Net::SIP::Leg where request came in (and response gets send out) # $addr: ip:port where request came from and response will be send # Returns: $code # $code: response code used in response (usually 200, but can be 423 # if expires was too small). If not given no response was created # and packet was ignored ########################################################################### sub receive { my Net::SIP::Registrar $self = shift; my ($packet,$leg,$addr) = @_; # accept only REGISTER $packet->is_request || return; if ( $packet->method ne 'REGISTER' ) { # if we know the target rewrite the destination URI my $addr = sip_parts2uri((sip_uri2parts($packet->uri))[0,1,2]); DEBUG( 1,"method ".$packet->method." addr=<$addr>" ); my @found = $self->query( $addr ); @found or do { DEBUG( 1, "$addr not locally registered" ); return; }; DEBUG( 1,"rewrite URI $addr in ".$packet->method." to $found[0]" ); $packet->set_uri( $found[0] ); return; # propagate to next in chain } my $to = $packet->get_header( 'to' ) or do { DEBUG( 1,"no to in register request. DROP" ); return; }; # what address will be registered ($to) = sip_hdrval2parts( to => $to ); if ( my ($domain,$user,$proto) = sip_uri2parts( $to ) ) { # normalize if possible $to = "$proto:$user\@$domain"; } # check if domain is allowed if ( my $rd = $self->{domains} ) { my ($domain) = $to =~m{\@([\w\-\.]+)}; if ( ! first { $domain =~m{\.?\Q$_\E$}i || $_ eq '*' } @$rd ) { DEBUG( 1, "$domain matches none of my own domains. DROP" ); return; } } my $disp = $self->{dispatcher}; my $loop = $disp->{eventloop}; my $now = int($loop->looptime); my $glob_expire = $packet->get_header( 'expires' ); # to which contacs it will be registered my @contact = $packet->get_header( 'contact' ); my %curr; foreach my $c (@contact) { # update contact info my ($c_addr,$param) = sip_hdrval2parts( contact => $c ); $c_addr = $1 if $c_addr =~m{<(\w+:\S+)>}; # do we really need this? my $expire = $param->{expires}; $expire = $glob_expire if ! defined $expire; $expire = $self->{max_expires} if ! defined $expire || $expire > $self->{max_expires}; if ( $expire ) { if ( $expire < $self->{min_expires} ) { # expire to small my $response = $packet->create_response( '423','Interval too brief', ); $disp->deliver( $response, leg => $leg, dst_addr => $addr ); return 423; } $expire += $now if $expire; } $curr{$c_addr} = $expire; } $self->{store}{ $to } = \%curr; # expire now! $self->expire(); DEBUG_DUMP( 100,$self->{store} ); # send back a list of current contacts my $response = $packet->create_response( '200','OK' ); while ( my ($where,$expire) = each %curr ) { $expire -= $now; $response->add_header( contact => "<$where>;expires=$expire" ); } # send back where it came from $disp->deliver( $response, leg => $leg, dst_addr => $addr ); return 200; } ########################################################################### # return information for SIP address # Args: ($self,$addr) # Returns: @sip_contacts ########################################################################### sub query { my Net::SIP::Registrar $self = shift; my $addr = shift; DEBUG( 50,"lookup of $addr" ); my $contacts = $self->{store}{$addr} || return; return grep { m{^sips?:} } keys %$contacts; } ########################################################################### # remove all expired entries from store # Args: $self # Returns: none ########################################################################### sub expire { my Net::SIP::Registrar $self = shift; my $disp = $self->{dispatcher}; my $loop = $disp->{eventloop}; my $now = $loop->looptime; my $store = $self->{store}; my (@drop_addr,$next_exp); while ( my ($addr,$contact) = each %$store ) { my @drop_where; while ( my ($where,$expire) = each %$contact ) { if ( $expire<$now ) { push @drop_where, $where; } else { $next_exp = $expire if ! $next_exp || $expire < $next_exp; } } if ( @drop_where ) { delete @{$contact}{ @drop_where }; push @drop_addr,$addr if !%$contact; } } delete @{$store}{ @drop_addr } if @drop_addr; # add timer for next expire if ( $next_exp ) { my $last_timer = \$self->{_last_timer}; if ( ! $$last_timer || $next_exp < $last_timer || $$last_timer <= $now ) { $disp->add_timer( $next_exp, [ \&expire, $self ] ); $$last_timer = $next_exp; } } } 1; Net-SIP-0.822/lib/Net/SIP/Registrar.pod0000644000175100017510000000504413223632330016031 0ustar workwork =head1 NAME Net::SIP::Registrar - Endpoint for registering SIP clients =head1 SYNOPSIS my $reg = Net::SIP::Registrar->new( dispatcher => $dispatcher, min_expires => 10, max_expires => 60, domains => [ 'example.com','example.org' ], ); =head1 DESCRIPTION This package implements a simple SIP registrar. In the current implementation registry information are only kept in memory, e.g. they are not preserved over restarts. The implementation itself does not checking if the UAC is authorized to register the given address. This can be done with using an appropriate Authorize Module inside a ReceiveChain in front of the registrar. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) This creates a new registar object, %ARGS can have the following keys: =over 8 =item dispatcher L object manging the registar. Mandatory. =item max_expires Maximum expires time accepted. If the client requests a larger expires value it will be capped at B Defaults to 300. =item min_expires Minimum expires value. If the client requests a smaller value the registrar will return a response of C<< 423 Interval too brief >>. Defaults to 30. =item domains or domain Either string or reference to list of strings containing the names of the domains the registrar is responsable for. If not given the registrar accepts everything. =back =back =head1 METHODS =over 4 =item receive ( PACKET,LEG,FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. Responses will be send back to the sender through the same leg. Called from the managing L object if a new packet arrives. Will return C<()> and ignore the packet if it's not a REGISTER request or if it is not responsable for the domain given in the C heeader of the REGISTER request. If it is responsable for the packet it will create a response and return the code of the response. Responses are either C<< 423 Interval too brief >> if the request expires time is too small, or C<< 200 Ok >> if the expires time is 0 (e.g. the client should be unregistered) or greater or equal B. In case of a successful response it will also update the internal registry information. =item query ( ADDR ) Search for ADDR (which has format C<< proto:user@domain >>) in the registry. Returns @List of all sip or sips contacts for ADDR. =item expire Removes all expired entries from the internal registry. Called whenever the registry information gets updated from sub B. =back Net-SIP-0.822/lib/Net/SIP/Redirect.pm0000644000175100017510000000313213013325717015463 0ustar workwork########################################################################### # package Net::SIP::Redirect # uses Registrar to redirect incoming calls based on the information # provided by the registrar ########################################################################### use strict; use warnings; package Net::SIP::Redirect; use fields qw(dispatcher registrar); use Net::SIP::Debug; use Net::SIP::Util ':all'; sub new { my ($class,%args) = @_; my $self = fields::new($class); %$self = %args; $self->{dispatcher} or croak( "no dispatcher given" ); $self->{registrar} or croak( "no registrar given" ); return $self; } sub receive { my Net::SIP::Redirect $self = shift; my ($packet,$leg,$addr) = @_; $packet->is_request or return; # don't handle responses my $method = $packet->method; my $resp; if ( $method eq 'ACK' ) { # if I got an ACK cancel delivery of response to INVITE $self->{dispatcher}->cancel_delivery( $packet->tid ); return -1; # don't process in next part of chain } elsif ( $method eq 'CANCEL' ) { $resp = $packet->create_response(200); } elsif ( $method eq 'REGISTER' ) { return; # don't process myself } else { my $key = sip_parts2uri((sip_uri2parts($packet->uri))[0,1,2]); if ( my @contacts = $self->{registrar}->query($key)) { $resp = $packet->create_response('302','Moved Temporarily'); $resp->add_header( contact => $_ ) for(@contacts); } else { $resp = $packet->create_response('404','Not found'); } } $self->{dispatcher}->deliver($resp,leg => $leg,dst_addr => $addr); return $resp->code; } 1; Net-SIP-0.822/lib/Net/SIP/Authorize.pod0000644000175100017510000000772511433431735016060 0ustar workwork =head1 NAME Net::SIP::Authorize - enforce authorization of packets =head1 SYNOPSIS my $auth = Net::SIP::Authorize->new( dispatcher => $dispatcher, realm => 'net-sip.example.com', user2pass => \&give_pass_for_user, i_am_proxy => 1, ); my $proxy = Net::SIP::StatelessProxy->new... my $chain = Net::SIP::ReceiveChain->new( # all requests for proxy need to be authorized [ $auth,$proxy ] ); =head1 DESCRIPTION This package is used inside a L to make sure, that requests are authorized before they get handled by the next receiver in the chain. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) This creates a new registar object, %ARGS can have the following keys: =over 8 =item dispatcher L object manging the registar. Mandatory. =item realm The realm for the authentication request. Defaults to 'p5-net-sip'. =item opaque Optional value for C parameter for the authentication request. If none is given no C parameter will be used. =item user2a1 Either hash reference with C mapping or callback, which gives C if called with C. For the meaning of C see RFC 2617. =item user2pass Either hash reference with C mapping or callback, which gives C if called with C. This parameter will only be used if C does not result in a defined C for C. =item i_am_proxy Flag if the object behind works as a proxy (e.g. L) and sends C or if it is an endpoint (e.g. L, L) which sends C. =item filter Additional filter for authorization, e.g. if authorization based on username and passwort succeeded it might still fail because of these filters. Filter is a hash with the method as key. The value can be an additional authorization (in which case it must succeed), a list of authorizations (all of them must succeed), or a list with a list of authorizations (at least one of the inner lists must succeed). The additional authorization can be a name of a L subclass (e.g. C means C) which has a C function or a C<[\&callback]>. The verify function or callback will be called with C<($packet,$leg,$addr,$auth_user,$auth_realm)> where C<$packet> is the request, C<$leg> the L object where the packet came in, C<$addr> the senders address, C<$auth_user> the username from the authorized user and C<$auth_realm> the realm which was used for authorization. Success for verification means that the function must return true. The following authorization subclasses are defined: =over 4 =item FromIsRealm Succeeds if the senders domain is the realm or a subdomain of the realm. =item FromIsAuthUser Succeeds if the username of the sender equals the username used for authorization. =item ToIsFrom Succeeds if To header equals From header. This can be used to make sure, that a user can only call REGISTER for itself. =back Example: filter => { REGISTER => [ # all of these must succeed [ 'ToIsFrom','FromIsRealm','FromIsAuthUser' ], # or this [ \&callback ], ], INVITE => 'FromIsRealm', } =back =back =head1 METHODS =over 4 =item receive ( PACKET,LEG,FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. Responses will be send back to the sender through the same leg. Called from the managing L object if a new packet arrives. Returns TRUE if the packet was fully handled by this object which is the case, if the packet was not authorized so that a C<401> or C<407> (if C) response was send back. Returns FALSE if packet was authorized and should be handled be the next object in the L. In this case it usually changes the packet to remove the local authorization information. =back Net-SIP-0.822/lib/Net/SIP/Response.pod0000644000175100017510000000123513005561434015667 0ustar workwork =head1 NAME Net::SIP::Response - handling of SIP response packets =head1 SYNOPSIS my $resp = Net::SIP::Response->new( '401','Authorization required',... ); =head1 DESCRIPTION Subclass of L for handling response packets. =head1 CONSTRUCTOR Inherited from L. See there. Seldom used directly, usually responses get not generated from scratch, but based on a request with the B method from L. =head1 METHODS =over 4 =item code Get numerical code of response. =item msg Get text for code from response. =item method Get method for original request by parsing the CSeq header. =back Net-SIP-0.822/lib/Net/SIP/SDP.pod0000644000175100017510000000764613005561434014533 0ustar workwork =head1 NAME Net::SIP::SDP - Parsing and manipulation of SDP data for SIP =head1 SYNOPSIS my $sdp = Net::SIP::SDP->new( sdp_string ); my @media = $sdp->get_media; =head1 DESCRIPTION Net::SIP::SDP can parse and manipulate SDP data. It's not a general purpose SDP class (like L) but designed to work with SDP data contained in SIP packets and for easy extraction and manipulation (for NAT etc) of media information contained in the SDP. The class is also designed for easy creation of SDP bodies in the context of the rest of Net::SIP::*. =head1 EXAMPLES # creation based on media data my $sdp = Net::SIP::SDP->new( { addr => '192.168.0.1' }, { port => 2012, proto => 'RTP/AVP', media => 'audio', fmt => 0 }, { port => 2014, proto => 'RTP/AVP', media => 'video', fmt => 0 }, ); # parse from string my $sdp = Net::SIP::SDP->new( sdp_string ); # extract all media data my @media = $sdp->get_media; # and replace them with new addr + port (for NAT) my @new_media,; foreach (@media) { my ($port,@socks) = create_rtp_sockets( '192.168.178.1', $_->{range} ); push @new_media, [ '192.168.178.1', $port ]; ... } $sdp->replace_media_listen( @new_media ); =head1 CONSTRUCTOR =over 4 =item new Default constructor. Depending on kind of arguments branches into B or B. See there. =item new_from_string ( STRING ) Creates object from STRING containing the SDP data. Raises an exception (e.g. die()) if SDP is invalid. =item new_from_parts ( \%GLOBAL, @MEDIA ) Creates object from specification. %GLOBAL describes the global keys, usually only a common C for all media but any of the keys defined in L can be used. @MEDIA is a list of hash references, one hash for each media part. These hashes can contain as keys the one-letter keys specified in L and/or special keys for constructing the 'c' and 'm' line: =over 8 =item addr - The address, used in the 'c' line. =item port - The port number =item range - Range of ports, for RTP/AVP defaults to 2, else 1 =item media - The media typ, e.g. 'audio','video',... =item proto - Transport protocol, ususally 'RTP/AVP' or 'udp' =back If the SDP should contain multiple values for the same key in the same media section on can specify the value for the key as a \@list instead of a string (this is often the case for 'a' lines). =back =head1 METHODS =over 4 =item as_string Returns string representation for object. =item content_type Returns 'application/sdp' =item get_media Returns list of all media described in the SDP. If the caller expects an array the result will be a list, otherwise a reference to a list. Each element of the list is a hash with the following keys: =over 8 =item addr - IP4/IP6 address for media =item port - Start port =item range - Range for ports =item proto - Media proto, usually 'RTP/AVP' or 'udp' =item media - Media typ, usually 'audio', 'video' or 'data' =item fmt - Format info from media line as \@list, e.g C<< [ 0,10,5 ] >>. =item lines - All lines from media description as \@list of [ key,value ]. =back B You should never manipulate the values you got from this function, because this might affect the objects internals. =item replace_media_listen ( NEW_MEDIA ) Replaces the exisisting media in the object with new media. Useful for NAT. NEW_MEDIA is ether an array or a reference to an array. Each element in the list consists of the new [ addr,port ] mapping for the matching media entry. The number of entries in the list should be the same as the number of media entries in the object ( see B ). If this is not the case it will C. =item name2int ( NAME, INDEX ) Returns the RTP payload id for NAME (e.g. "telephone-event/8000"). INDEX is the index into the list of media information, matching the list returned from L. INDEX can also be 'audio','video'.., which will then lookup at the first matching entry in the media list. =back Net-SIP-0.822/lib/Net/SIP/Debug.pod0000644000175100017510000001134113013420244015106 0ustar workwork =head1 NAME Net::SIP::Debug - debugging of Net::SIP =head1 SYNOPSIS use Net::SIP::Debug '1'; use Net::SIP::Debug qw( Net::SIP*=0 Registrar=1 ); Net::SIP::Debug->level(1); perl -MNet::SIP::Debug=1 app.pl =head1 DESCRIPTION Provides debugging support for L. Debugging can be enabled/disabled globally or per package and optional per subpackage. It provides support for different debugging levels, e.g. the higher the level, the more debugging is done. The following levels are used: =over 4 =item 1 - Debug messages for users. =item 2 - Includes short SIP packet dumps of incoming and outgoing data. =item 5 - Includes detailed SIP packet dumps for incoming and outgoing data. =item 10 - Includes information about call flow, e.g. why packets get dropped etc. =item 50 - Detailed debugging for programmers using L. =item 100 - Detailed debugging for core developers of L. =back =head1 CLASS METHODS =over 4 =item import ( @ARGS ) Extracts everything from arguments given to C which might be usable by B and forwards rest to L. If the argument is a reference to a subroutine it will be used for showing the debug message instead of printing it to STDERR. In this case the usual prefixes incl the time will not be added (useful for forwarding debug to syslog). =item level ( @ARGS ) Enables/disables debugging depending on @ARGS. @ARGS might contain the following specifications: =over 8 =item NUMBER NUMBER will be interpreted as the debugging level. It's used in B etc to print only debug message which a level lower or equal to NUMBER. =item PACKAGE Enables debugging for package PACKAGE. PACKAGE might be a fully qualified package (e.g. C) or the C or C might be omitted (C). If a C<*> is added the debugging will also be enabled for subpackages, e.g. C will enable debugging for L and L too. =item PACKAGE=NUMBER Similar to the previous item, but this sets debugging level to NUMBER for the specified packages and thus can also be used to selectively disable debugging for some packages. =back If @ARGS is empty it will return the debugging level for the package which called this method (the first package in the caller stack which is not Net::SIP::Debug itself). =item set_prefix ( PREFIX ) Sets prefix used for debug messages to PREFIX. Default prefix is 'DEBUG:' but for instance for forking applications it might be useful to change this to "DEBUG($$):" or similar. =back =head1 SUBROUTINES =over 4 =item DEBUG|debug ( [ LEVEL ],( MESSAGE | FMT,@ARG )) If debugging is enabled it will print debugging info to STDERR. If multiple arguments are given to the function they will be fed into B to create a single message. If the first argument looks like a number (see B in L) it will be interpreted as the debug level for this message, e.g. if it is higher than the user specified debug level the message will not be printed. The MESSAGE (or the result from C<< sprintf(FMT,@ARG) >>) will be prefixed by the caller package, the caller function and the line from which DEBUG was called. In front of the prefix the current time (as float time_t) and the string "DEBUG:" will be added. If the message consists of multiple lines each line will be prefixed by the prefix and all but the first line will also have a TAB added between prefix and message data. The function is by default exported as B and can by exported as B too. =item DEBUG_DUMP ( [ LEVEL ], @DATA ) Will call B with the output from Ls B if debugging is enabled. If @DATA has more than one item it will be fed as reference into B, otherwise only the single item will be fed to B. For the meaning of LEVEL see B. This function is exported by default. =item stacktrace ( MESSAGE | FMT,@ARG ) Uses the arguments in B, but instead of writing a debug message to STDERR it will be used in Carp::longmess. Returns string with stacktrace. =item LEAK_TRACK ( REF ) This is used internally for tracking leaks. It will rebless REF into a new class which behaves like the old one. Calls of LEAK_TRACK and DESTROY on this class will be tracked and shown. If L can be loaded it will B information about the REF on each call to LEAK_TRACK. Exported by default. =back =head1 exported Variables =over 4 =item $DEBUG This variable is set to false if all kind of debugging is disabled. This variable is exported by default. It should not be changed. It is intended to be used as a quick check to save expensive calls of debugging functions if no debugging will be used anyway, i.e.: $DEBUG && DEBUG(...) =back Net-SIP-0.822/lib/Net/SIP/Redirect.pod0000644000175100017510000000247412656712670015653 0ustar workwork =head1 NAME Net::SIP::Redirect - Send redirect to Requests based on lookup at a registrar =head1 SYNOPSIS my $reg = Net::SIP::Registrar->new(...); my $redir = Net::SIP::Redirect( dispatcher => $dispatcher, registrar => $reg, ); =head1 DESCRIPTION This package implements a simple redirection of Requests using the information provided by a registrar. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) This creates a new redirect object, %ARGS can have the following keys: =over 8 =item dispatcher L object managing the registar. Mandatory. =item registrar Registrar object. This is an object like a L, which has a C method which returns a list of contacts. =back =back =head1 METHODS =over 4 =item receive ( PACKET,LEG,FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. Responses will be send back to the sender through the same leg. Called from the managing L object if a new packet arrives. Will return C<()> and ignore the packet if it's an REGISTER request. For Requests it will query the registrar and return either C<< 302 Moved Temporarily >> with the list of contacts or C<< 404 Not Found >> if the address is not registered. =back Net-SIP-0.822/lib/Net/SIP/StatelessProxy.pod0000644000175100017510000001053613172714503017110 0ustar workwork =head1 NAME Net::SIP::StatelessProxy - Simple implementation of a stateless proxy =head1 SYNOPSIS .. =head1 DESCRIPTION This package implements a simple stateless SIP proxy. Basic idea is that the proxy has either a single or two legs and that the packets are exchanged between those legs, e.g. packets incoming on one leg will be forwarded through the other leg. Because this is a stateless proxy no retransmits will be done by the proxy. If the proxy should work as a registrar too it should be put after a L in a L. While forwarding the proxy will be insert itself into the packet, e.g. it will add B and B header while forwarding requests. Additionally it will rewrite the B header while forwarding packets (see below), e.g. if the B header points to some client it will rewrite it, so that it points to the proxy and if it already points to the proxy it will rewrite it back so that it again points to the client. =head1 CONSTRUCTOR =over 4 =item new ( %ARGS ) Creates a new stateless proxy. With %ARGS the behavior can be influenced: =over 8 =item dispatcher The L object managing the proxy. =item rewrite_contact Callback which is used in rewriting B headers. If one puts user@host in it or if it is called with B then it should rewrite it and if one puts something without '@' it should try to rewrite it back or return B<()> if it cannot be rewritten back. A working default implementation is provided. If you want to implement your own: the callbacks gets the arguments B, B and B and B. For rewriting a contact of user@host the legs will be L objects. For rewriting the contact back B can be either a leg object and you should check if it is the expected leg. Or it is a scalar reference which you should fill with the leg extracted from the contact. The function should return the new contact or nothing if there was nothing to rewrite or the rewrite failed. Note that some servers apply length limitiations to the contact so the function should not return too long values. =item rewrite_crypt If you want to have your own encryption for the rewritten contact you should defined a subroutine here, which gets C as the first and C as the second parameter and should return the de/encrypted data. If C is +1 it should encrypt and on -1 it should decrypt. The optional third argument C should be included in calculation and verification of the MAC. The function should return the encrypted/decrypted data or undef if decryption failed because the MAC did not match. If not defined, then RC4 will be used with a (pseudo)random key, 4 byte (pseudo)random seed and 4 byte MAC (md5) over seed and data. =item nathelper Optional Net::SIP::NATHelper::* object. When given it will be used to do NAT, e.g. if the incoming and outgoing legs are different it will rewrite the SDP bodies to use local sockets and the nathelper will transfer the RTP data between the local and the original sockets. =item force_rewrite Usually the contact header will only be rewritten, if the incoming and outgoing leg are different. With this option one can force the rewrite, even if they are the same. =back =back =head1 METHODS =over 4 =item receive ( PACKET, LEG, FROM ) PACKET is the incoming packet, LEG is the L where the packet arrived and FROM is the C<< "ip:port" >> of the sender. Called from the dispatcher on incoming packets. The packet will be rewritten (C and C headers added, B modified) and then the packet will be forwarded. For requests it can determine the target of the forwarded packet by looking at the route or if no route it looks at the URI. For responses it looks at the next B header. =item do_nat ( PACKET, INCOMING_LEG, OUTGOING_LEG ) This will be called from B while forwarding data. If B is defined it will be used to rewrite SDP bodies and update nathelpers internal states to forward RTP data. Return values are like B in L, e.g. it will return C<< [code,text] >> on error or C<()> on success, where success can be that the packet was rewritten or that there was no need to touch it. =back =head1 UNDOCUMENTED METHODS =over 4 =item idside2hash =back Net-SIP-0.822/lib/Net/SIP.pod0000644000175100017510000001346213205220600014063 0ustar workwork =head1 NAME Net::SIP - Framework SIP (Voice Over IP, RFC3261) =head1 SYNOPSIS ... =head1 DESCRIPTION Net::SIP consists of packages for handling the SIP packets, for transport of the packets, for processing the packets and on top of all that a simplified layer for common tasks. Addionally L provides utility functions and L provides a debugging layer used by all these packages. Especially it provides the function B which is used for all callbacks unless documentation specifies otherwise. This function supports a variety of different callback styles. For first and simple applications you best start with L. If this is no longer enough you might look at the details of L, L, L and L. Although these packages are in itself well documented the functionality and the design is best understandable if you look how it gets used in the source of L. =head2 SIP packet handling =over 4 =item L The base class for handling SIP packets and provides ways to parse, construct and manipulate SIP packets. =item L Derived from L and handles the request packets. Provides ways to create special requests like ACK or CANCEL based on previous requests and responses, for creating responses based on requests, for authorization of requests. =item L Derived from L and handles the response packets. =item L Handles SDP bodies from SIP packets. Provides ways to parse, construct these bodies, to get media information from them and to manipulate the SDP data for NAT etc. =back =head2 Transport of SIP packets =over 4 =item L Encapsulates socket for transport of packet. Provides way to find out, if target is reachable through this socket. Prepares incoming, outgoing and forwarding packets by removing or adding header like B, B. =item L Handles new packets coming in through a L. Delivers outgoing packets through the appropriate L. Handles timeouts and retransmission of outgoing packets, lookup of the appropriate leg through DNS etc. =item L Simple implementation of an event loop for handling socket events and timers. Can be replaced to integrate into other event loops, like L, L or L. =back =head2 Processing of SIP packets, application layer =over 4 =item L Implements a SIP endpoint (UAC,UAS). Provides ways to INVITE or BYE calls or to handle incoming calls. Calls themselves will be handled by L. =item L Simple implementation of a registrar. =item L Simple implementation of a stateless proxy. Stateful proxies should probably be implemented by putting multiple Ls together. =item L Can block requests by method name with custom error code. =item L Can contain various objects for processing objects. Useful in connection with L. =item L Works together with a registrar and redirects requests. =item L If put into a L it requests and checks authorization and gives only authorized requests to the next member of the chain. =back =head2 Simplified Layer for common tasks =over 4 =item Net::SIP::Simple Provides simple layer for common tasks and tests, like sending a voice message to somebody, receiving a message or even implementing an answer machine. Together with L it is possible to handle simple RTP data (PCMU/8000). =back =head2 Error handling Unless otherwise documented the common way to propagate errors is to raise an exception, e.g. call die(). This might especially happen when parsing packets from strings, so unless you want to crash your application on bad input you should catch these exceptions with eval. =head1 EXPORTS By default nothing is exported. There are various arguments for exporting: =over 4 =item :alias Exports constants as aliases for the Net::SIP::* packages, e.g. 'Simple' for 'Net::SIP::Simple', 'Registrar' for 'Net::SIP::Registrar', 'Packet' for 'Net::SIP::Packet', 'NATHelper_Client' for 'Net::SIP::NATHelper::Client' etc. =item :util Exports everything (tag ':all') from L. =item :debug Exports the default exports from L. =item :all Everything from ':debug', ':util' and ':alias'. =item rtp=MINPORT-MAXPORT|rtp:MINPORT-MAXPORT Set the range of ports to be used for creating RTP sockets to MINPORT..MAXPORT. This affects L. =item debug=LEVEL|debug:LEVEL Set Debugging level to LEVEL =item string Strings where the first character is upper case will be interpreted as aliases for Net::SIP::* and it will try to export it. If the first character is lower case it will try to import it from L. =back =head2 EXAMPLES use Net::SIP 'invoke_callback'; # use Net::SIP::Util 'invoke_callback' use Net::SIP ':debug'; # use Net::SIP::Debug use Net::SIP ':util'; # use Net::SIP::Util ':all' use Net::SIP ':alias'; Packet->new( ... ); # Net::SIP::Packet->new( ... ) # restrict rtp sockets from command line perl -MNet::SIP=rtp:4000-4010 program.pl =head1 BUGS Support for TCP and SIPS and not or not fully implemented. =head1 COPYRIGHT This module and are modules in the Net::SIP Hierarchy distributed together with this module are copyright (c) 2006-2013, Steffen Ullrich. All Rights Reserved. These modules are free software. They may be used, redistributed and/or modified under the same terms as Perl itself. Net-SIP-0.822/lib/Net/SIP.pm0000644000175100017510000000412513552314430013723 0ustar workworkuse strict; use warnings; use 5.010; package Net::SIP; our $VERSION = '0.822'; # this includes nearly everything else use Net::SIP::Simple (); use Net::SIP::Simple::Call (); use List::Util 'first'; # do not include these, because they are only # used when we do NAT # use Net::SIP::NATHelper::Base; # use Net::SIP::NATHelper::Local; # use Net::SIP::NATHelper::Client; # use Net::SIP::NATHelper::Server; use base 'Exporter'; our (@EXPORT_OK, %EXPORT_TAGS); BEGIN { foreach ( qw( Net::SIP::Request Net::SIP::Response Net::SIP::Packet Net::SIP::SDP Net::SIP::Simple Net::SIP::Simple::RTP Net::SIP::Dispatcher Net::SIP::Dispatcher::Eventloop Net::SIP::Redirect Net::SIP::Registrar Net::SIP::StatelessProxy Net::SIP::Blocker Net::SIP::ReceiveChain Net::SIP::Authorize Net::SIP::Endpoint Net::SIP::NATHelper::Client Net::SIP::NATHelper::Server Net::SIP::NATHelper::Local Net::SIP::Debug Net::SIP::Dropper Net::SIP::Leg )) { my $pkg = $_; # copy from alias my $sub; if ( $pkg =~m{^Net::SIP::(.*)} ) { ( $sub = $1 ) =~s{::}{_}g; } elsif ( $pkg =~m{::(\w+)$} ) { $sub = $1; } if ( $sub ) { no strict 'refs'; *{ $sub } = sub () { $pkg }; push @EXPORT_OK,$sub; push @{ $EXPORT_TAGS{alias} },$sub; }; } } sub import { my $class = shift; my @tags = @_; while ( my $tag = shift(@tags)) { if ( $tag eq ':all' ) { push @tags,':alias',':util',':debug'; } elsif ( $tag eq ':util' ) { Net::SIP::Util->export_to_level(1,$class,':all') } elsif ( $tag eq ':debug' ) { Net::SIP::Debug->export_to_level(1,$class,':DEFAULT') } elsif ( $tag eq ':alias' ) { $class->export_to_level(1,$class,$tag); } elsif ( $tag =~m{rtp[=:](\d+)-(\d+)}i ) { $Net::SIP::Util::RTP_MIN_PORT = $1; $Net::SIP::Util::RTP_MAX_PORT = $2; } elsif ( $tag =~m{^debug[=:](.*)}i ) { Net::SIP::Debug->level($1); } elsif ( first { $_ eq $tag } @EXPORT_OK ) { # from the predefined list $class->export_to_level(1,$class,$tag); } else { # default try to import from Net::SIP::Util Net::SIP::Util->export_to_level(1,$class,$tag) } } } 1; Net-SIP-0.822/BUGS0000644000175100017510000000010411136273030012106 0ustar workwork* TCP support not fully implemented * SIPS support not implemented Net-SIP-0.822/samples/0000755000175100017510000000000013552315100013073 5ustar workworkNet-SIP-0.822/samples/invite_and_recv.pl0000644000175100017510000001210512271424737016604 0ustar workwork########################################################################### # Invite other party, recv RTP data for some seconds or until other side # hangs up, then BYE # optional registration # # Most of the code is option parsing and usage, the Net::SIP related code # is at the end ########################################################################### use strict; use warnings; use IO::Socket::INET; use Getopt::Long qw(:config posix_default bundling); use Net::SIP; use Net::SIP::Util 'create_socket_to'; use Net::SIP::Debug; sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, 'P|proxy=s' => \$proxy, 'R|registrar=s' => \$registrar, 'O|outfile=s' => \$outfile, 'T|time=i' => \$hangup, 'L|leg=s' => \$local_leg, 'C|contact=s' => \$contact, 'username=s' =>\$username, 'password=s' =>\$password, 'route=s' => \@routes, ) || usage( "bad option" ); Net::SIP::Debug->level( $debug || 1 ) if defined $debug; my ($from,$to) = @ARGV; $to || usage( "no target" ); # register at proxy if proxy given and no registrar $registrar ||= $proxy; ################################################### # find local leg ################################################### my ($local_host,$local_port); if ( $local_leg ) { ($local_host,$local_port) = split( m/:/,$local_leg,2 ); } elsif ( ! $proxy ) { # if no proxy is given we need to find out # about the leg using the IP given from FROM ($local_host,$local_port) = $from =~m{\@([\w\-\.]+)(?::(\d+))?} or die "cannot find SIP domain in '$from'"; } my $leg; if ( $local_host ) { my $addr = gethostbyname( $local_host ) || die "cannot get IP from SIP domain '$local_host'"; $addr = inet_ntoa( $addr ); $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => $local_port || 5060, ); # if no port given and port 5060 is already used try another one if ( !$leg && !$local_port ) { $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => 0 ) || die "cannot create leg at $addr: $!"; } $leg = Net::SIP::Leg->new( sock => $leg ); } ################################################### # SIP code starts here ################################################### # create necessary legs # If I have an only outgoing proxy I could skip this step because constructor # can make leg to outgoing_proxy itself my @legs; push @legs,$leg if $leg; foreach my $addr ( $proxy,$registrar) { $addr || next; if ( ! grep { $_->can_deliver_to( $addr ) } @legs ) { my $sock = create_socket_to($addr) || die "cannot create socket to $addr"; push @legs, Net::SIP::Leg->new( sock => $sock ); } } # create user agent my $ua = Net::SIP::Simple->new( from => $from, outgoing_proxy => $proxy, route => \@routes, legs => \@legs, $contact ? ( contact => $contact ):(), $username ? ( auth => [ $username,$password ] ):(), ); # optional registration if ( $registrar && $registrar ne '-' ) { $ua->register( registrar => $registrar ); die "registration failed: ".$ua->error if $ua->error } # invite peer my $peer_hangup; # did peer hang up? my $call = $ua->invite( $to, # echo back, use -1 instead of 0 for not echoing back init_media => $ua->rtp( 'recv_echo', $outfile,0 ), recv_bye => \$peer_hangup, ) || die "invite failed: ".$ua->error; die "invite failed(call): ".$call->error if $call->error; # mainloop until other party hangs up or we hang up after # $hangup seconds my $stopvar; $ua->add_timer( $hangup, \$stopvar ) if $hangup; $ua->loop( \$stopvar,\$peer_hangup ); # timeout, I need to hang up if ( $stopvar ) { $stopvar = undef; $call->bye( cb_final => \$stopvar ); $ua->loop( \$stopvar ); } Net-SIP-0.822/samples/bench/0000755000175100017510000000000013552315100014152 5ustar workworkNet-SIP-0.822/samples/bench/listen.pl0000644000175100017510000000221512271424737016023 0ustar workworkuse strict; use Net::SIP qw(:all); use Getopt::Long qw(:config posix_default bundling); my $debug; my $from = 'sip:me@two.example.com'; my $leg = '127.0.0.1:5070'; my $registrar; GetOptions( 'd|debug:i' => \$debug, 'h|help' => sub { usage() }, 'F|from=s' => \$from, 'L|leg=s' => \$leg, 'R|registrar=s' => \$registrar, ) || usage( 'bad options' ); Debug->level( $debug || 1 ) if defined $debug; my $ua = Simple->new( from => $from, leg => $leg, registrar => $registrar, ); if ( $registrar ) { die "Registration failed\n" if ! $ua->register; print STDERR "Registered\n"; } $ua->listen( # echo everything back init_media => $ua->rtp( 'recv_echo' ), ); print "Listening...\n"; $ua->loop; sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, 'F|from=s' => \$from, 'T|to=s' => \$to, 'P|proxy=s' => \$outgoing_proxy, 'S|stat-timer=i' => \$stat_timer, 'N|parallel=i' => \$ncalls, ) || usage( 'bad options' ); Debug->level( $debug || 1 ) if defined $debug; my $loop = Net::SIP::Dispatcher::Eventloop->new; my $ua = Simple->new( from => $from, outgoing_proxy => $outgoing_proxy, loop => $loop, ); my (@connected,$start_bench,$min_delay,$max_delay); my $ignored = my $ok = my $lost = my $sum_delay = 0; for my $call (1..$ncalls) { my $connected; my $send_seq = 1; my $recv_seq = 0; $ua->invite( $to, cb_final => \$connected, init_media => $ua->rtp( 'send_recv', [ \&send_rtp, \$send_seq ], 0, [ \&recv_rtp, \$recv_seq ] ), ); push @connected,\$connected } $ua->loop( @connected ); print STDERR "All $ncalls calls connected....\n"; $start_bench = 1; my $start = time(); $ua->add_timer( $stat_timer, \&stat_timer, 2 ); $ua->loop; sub stat_timer { if ( $ok ) { printf "%5d pkt=%d/%d/%d delay(ms)=%.2f/%.2f/%.2f\n", time() - $start, $ok,$lost,$ignored, $sum_delay/$ok*1000, $min_delay*1000,$max_delay*1000; } else { printf "%5d pkt=%d/%d/%d\n", time() - $start, $ok,$lost,$ignored; } $sum_delay = $ok = $lost = $ignored = 0; $min_delay = $max_delay = undef; } sub send_rtp { my $rseq = shift; my $now = $loop->looptime; my $sec = int($now); my $msec = ( $now - $sec ) * 1_000_000; my $seq = $start_bench ? $$rseq++ : 0; return pack( "NNN",$seq,$sec,$msec ) . ( ' ' x 148 ); } sub recv_rtp { my ($rseq,$payload) = @_; my ($seq,$sec,$msec) = unpack( "NNN",$payload ); #print STDERR "seq=$seq\n"; return if ! $seq; # initial data my $diff = $seq - $$rseq; if ( $diff <= 0 || $diff > 10000 ) { # bogus, retransmits? $ignored++; return; } $lost += $diff-1; $$rseq = $seq; $ok++; my $now = $loop->looptime; my $then = $sec + $msec/10**6; my $delay = $now - $then; die "now=".localtime($now)." then=".localtime($then) if $delay<0; $sum_delay += $delay; $min_delay = $delay if ! defined $min_delay || $min_delay > $delay; $max_delay = $delay if ! defined $max_delay || $max_delay < $delay; } sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, ) || usage( 'bad options' ); Debug->level($debug || 1) if defined $debug; my ($laddr,$from,$to) = @ARGV; $to || usage( "no TO given" ); # create Dispatcher # ------------------------------------------------------------- my $loop = Dispatcher_Eventloop->new; my $leg = Leg->new( addr => $laddr ); my $disp = Dispatcher->new( [ $leg ], $loop, do_retransmits => 0 ) || die; $disp->set_receiver( \&receive ); my $me = ($disp->get_legs())[0]->{contact}; # create initial invite without SDP with # To: $to, From: $from, Contact: $me # put these info in call-id to be stateless # ------------------------------------------------------------- # assume no '|' is in $from and $to my $callid = "$from|$to|0|". sprintf( "%08x",rand(2**16)); my $invite = Request->new( "INVITE",$from, { from => $to, to => $from, contact => $me, 'call-id' => $callid, cseq => '1 INVITE', }); $disp->deliver( $invite, do_retransmits => 1 ); # and loop # ------------------------------------------------------------- my $stop_loop; $loop->loop( undef, \$stop_loop ); $loop->loop(1) if $stop_loop; # some time to forward remaining stuff ############################################################### # # callback for incoming packets: # # - there are two calls which slightly different call-id, with # a simple way one can get the other call-id from one call-id. # - responses are for me if there is only one via header, and # that's me -> handle to make requests (INVITE,ACK) from it # - all other responses get forwarded. If last via has a cseq # parameter they get forwarded after changing the cseq # - requests are for me if the URI is the contact of the local leg # -> forward to other call, but add "cseq" parameter to last # via so that the cseq of the calling uac gets saved for # responses # - all requests I get should be for me, because a contact header # is explicitly added # ############################################################### sub receive { my ($packet,$leg,$from_addr) = @_; # extract info from call-id my $callid = $packet->callid() or do { DEBUG( 1,"no callid in packet. DROP" ); return; }; my ($from,$to,$dir,$random) = split( qr{\|}, $callid ); my $new_callid = join( '|',$from,$to, $dir?0:1, $random ); my ( $request,$response ) = $packet->is_response ? ( undef,$packet ) : ( $packet, undef ); if ( $response ) { # ------------------------------------------------------------------ # Handle Responses: # - if it has only one via (and this is myself) it is a response # to a request which originated locally. In this case make # the appropriate request from it and forward it to the other side # - if it has more than one via just forward it to the other side # ------------------------------------------------------------------ # top via must be me my @via = $response->get_header( 'via' ); $leg->check_via($response) or do { DEBUG( 5, "top via isn't me: $via[0]" ); return; }; # exactly one via ? my $cseq = $response->cseq; my ($num,$method) = split( ' ',$cseq ); if ( @via == 1 ) { # cancel retransmits $disp->cancel_delivery( $response->tid ); if ( $method eq 'INVITE' && $dir == 0 ) { # --------------------------------------------------------- # response to initial INVITE ME->FROM # on success create INVITE ME->TO with SDP from response # --------------------------------------------------------- my $code = $response->code; if ( $code < 200 ) { # preliminary response, ignore and don't reply DEBUG( 10,"ignoring preliminary reply to initial invite" ); return; } elsif ( $code >= 300 ) { # non successful response (we don't care about redirects) # send ACK and ignore $disp->deliver( Request->new( 'ACK',$from, { 'call-id' => $callid, cseq => "$num ACK", to => scalar($response->get_header('from')), from => scalar($response->get_header('to')), contact => $me, })); } else { # success: extract SDP and forward in INVITE to # other party DEBUG( 10,"got success to initial INVITE" ); my $sdp = $response->sdp_body or do { DEBUG( 1,"no SDP in response to INVITE from $from" ); return; }; $disp->deliver( Request->new( 'INVITE', $to, { from => scalar($response->get_header( 'to' )), to => scalar($response->get_header( 'from' )), 'call-id' => $new_callid, contact => $me, cseq => "$num INVITE", }, $sdp, )); } } elsif ( $method eq 'INVITE' && $dir == 1 ) { # --------------------------------------------------------- # response from $to to the initial INVITE # on success create ACK # --------------------------------------------------------- my $code = $response->code; if ( $code < 200 ) { # preliminary response, ignore and don't reply DEBUG( 10,"ignoring preliminary reply from TO to initial invite" ); return; } # create ACK to TO $disp->deliver( Request->new( 'ACK', $to, { from => scalar($response->get_header( 'from' )), to => scalar($response->get_header( 'to' )), 'call-id' => $callid, contact => $me, cseq => "$num ACK", })); if ( $code >= 300 ) { # non successful response (we don't care about redirects) # cancel initial call [ME,FROM] DEBUG( 10,"got code $code on INVITE 'TO'" ); $disp->deliver( Request->new( 'CANCEL',$from, { 'call-id' => $new_callid, cseq => "$num INVITE", from => scalar($response->get_header( 'to' )), to => scalar($response->get_header( 'from' )), contact => $me, })); } else { DEBUG( 10,"got success on INVITE 'TO'" ); # success: extract SDP and forward in ACK to FROM my $sdp = $response->sdp_body or do { DEBUG( 1,"no SDP in response to INVITE from $to" ); return; }; $disp->deliver( Request->new( 'ACK', $from, { from => scalar($response->get_header( 'to' )), to => scalar($response->get_header( 'from' )), 'call-id' => $new_callid, contact => $me, cseq => "$num ACK", }, $sdp, )); } } } else { # --------------------------------------------------------- # response for forwarded request # change call-id and forward # --------------------------------------------------------- # get addr from next via my ($data) = sip_hdrval2parts( via => $via[1] ); my ($addr,$port) = $data =~m{([\w\-\.]+)(?::(\d+))?\s*$}; $port ||= 5060; # FIXME: not for sips! $response->set_header( contact => $me ); $leg->forward_incoming( $response ); $response->set_header( 'call-id' => $new_callid ); # check if the last via header had a cseq attribute. # in this case forward the response with the given cseq my ($via) = $response->get_header( 'via' ); my (undef,$param) = sip_hdrval2parts( via => $via ); if ( defined( my $num = $param->{cseq} )) { my $cseq = $response->cseq; $cseq =~s{^(\d+)}{$num}; $response->set_header( cseq => $cseq ); } # if this was response to BYE end this program $stop_loop = 1 if $method eq 'BYE'; $leg->forward_outgoing( $response,$leg ); $disp->deliver( $response, leg => $leg, dst_addr => "$addr:$port" ); } } else { # ------------------------------------------------------------------ # Handle requests from one of the parties # change call-id and cseq (because I have to use one of my cseqs) # and forward # ------------------------------------------------------------------ if ( $request->uri eq $leg->{contact} ) { # this is for me # could be CANCEL or BYE my $m = $request->method; if ( $m ne 'BYE' and $m ne 'CANCEL' ) { DEBUG( 10,"will not forward request to me with method $m" ); return; } # set URI to other party # if we were stateful we could store Contact infos from # older packets and use them here instead. $request->set_uri( $dir ? $from : $to ); } my ($num,$method) = split( ' ',$request->cseq ); # we just add 20 to the cseq we got from the uac # this is higher then every other locally generated cseq on # this side (we only used "1" until now for the first INVITE) $request->set_header( cseq => ( $num + 20 ).' '.$method ); $request->set_header( contact => $me ); $leg->forward_incoming( $request ); $request->set_header( 'call-id' => $new_callid ); # add cseq param to last via header because both calls maintain # different cseq spaces and we must know with which cseq we # need to forward the response if ( my @via = $request->get_header( 'via' ) ) { my ($data,$param) = sip_hdrval2parts( via => $via[0] ); $param->{cseq} = $num; $via[0] = sip_parts2hdrval( 'via',$data,$param ); $request->set_header( via => \@via ); } $leg->forward_outgoing( $request,$leg ); $disp->deliver( $request ) } } Net-SIP-0.822/samples/register_and_redirect.pl0000644000175100017510000000153712271424737020003 0ustar workwork#!/usr/bin/perl # sample program which allows anybody to register and then # redirects any INVITES to the registered addresses use strict; use warnings; use Net::SIP qw(:alias); my $loop = Dispatcher_Eventloop->new; my $leg = Leg->new(addr => $ARGV[0] || '192.168.178.3:5060'); my $disp = Dispatcher->new( [ $leg ], $loop); # Authorize # only user is looser|secret my $auth = Authorize->new( dispatcher => $disp, realm => 'net-sip.example.com', user2pass => { looser => 'secret' } ); # Registrar, accepts registration for every domain my $reg = Registrar->new( dispatcher => $disp ); # handles invites and redirects them to the contacts # provided by the registrar my $redir = Redirect->new( dispatcher => $disp, registrar => $reg, ); my $chain = ReceiveChain->new( [$auth,$redir,$reg]); $disp->set_receiver($chain); $loop->loop; Net-SIP-0.822/samples/test_registrar_and_proxy.pl0000644000175100017510000000127612271424737020600 0ustar workworkuse strict; use warnings; use Net::SIP; # This is a simple registrar + proxy which listens on 192.168.178.2 # for requests. Anybody can register with any address and if somebody # invites somebody using over this proxy it will first check if the # target address is locally registered and in this case forward the # invitation to the registered party. Otherwise it will try to resolve # the target using DNS and forward the request. # # Because it accepts any registration w/o passwords it's good for testing # but don't use it in production my $ua = Net::SIP::Simple->new( leg => '192.168.178.2:5060' ); $ua->create_chain([ $ua->create_registrar, $ua->create_stateless_proxy, ]); $ua->loop; Net-SIP-0.822/samples/invite_and_send.pl0000644000175100017510000001341012656712670016601 0ustar workwork########################################################################### # Invite other party, and send some files. Uses re-INVITEs to support # sending of multiple files. Exits once done or when peer hangs # up # # Most of the code is option parsing and usage, the Net::SIP related code # is at the end. The code is very similar to samples/invite_and_recv.pl, # the main difference is at the end, using media_send_recv instead of # media_recv_echo and doing re-invites on the same call ########################################################################### use strict; use warnings; use IO::Socket::INET; use Getopt::Long qw(:config posix_default bundling); use Net::SIP; use Net::SIP::Util 'create_socket_to'; use Net::SIP::Debug; sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, 'P|proxy=s' => \$proxy, 'R|registrar=s' => \$registrar, 'S|send=s' => \@files, 'L|leg=s' => \$local_leg, 'T|timeout=s' => \$ring_time, 'username=s' =>\$username, 'password=s' =>\$password, ) || usage( "bad option" ); Net::SIP::Debug->level( $debug || 1 ) if defined $debug; my ($from,$to) = @ARGV; $to || usage( "no target" ); # register at proxy if proxy given and no registrar $registrar ||= $proxy; ################################################### # find local leg ################################################### my ($local_host,$local_port); if ( $local_leg ) { ($local_host,$local_port) = split( m/:/,$local_leg,2 ); } elsif ( ! $proxy ) { # if no proxy is given we need to find out # about the leg using the IP given from FROM ($local_host,$local_port) = $from =~m{\@([\w\-\.]+)(?::(\d+))?} or die "cannot find SIP domain in '$from'"; } my $leg; if ( $local_host ) { my $addr = gethostbyname( $local_host ) || die "cannot get IP from SIP domain '$local_host'"; $addr = inet_ntoa( $addr ); $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => $local_port || 5060, ); # if no port given and port 5060 is already used try another one if ( !$leg && !$local_port ) { $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => 0 ) || die "cannot create leg at $addr: $!"; } $leg = Net::SIP::Leg->new( sock => $leg ); } ################################################### # SIP code starts here ################################################### # create necessary legs # If I have an only outgoing proxy I could skip this step because constructor # can make leg to outgoing_proxy itself my @legs; push @legs,$leg if $leg; foreach my $addr ( $proxy,$registrar) { $addr || next; if ( ! grep { $_->can_deliver_to( $addr ) } @legs ) { my $sock = create_socket_to($addr) || die "cannot create socket to $addr"; push @legs, Net::SIP::Leg->new( sock => $sock ); } } # create user agent my $ua = Net::SIP::Simple->new( from => $from, outgoing_proxy => $proxy, legs => \@legs, $username ? ( auth => [ $username,$password ] ):(), ); # optional registration if ( $registrar && $registrar ne '-' ) { $ua->register( registrar => $registrar ); die "registration failed: ".$ua->error if $ua->error } # invite peer, send first file my $peer_hangup; # did peer hang up? my $no_answer; # or didn't it even answer? my $rtp_done; # was sending file completed? my $call = $ua->invite( $to, # echo back, use -1 instead of 0 for not echoing back init_media => $ua->rtp( 'send_recv', $files[0] ), cb_rtp_done => \$rtp_done, recv_bye => \$peer_hangup, cb_noanswer => \$no_answer, ring_time => $ring_time, ) || die "invite failed: ".$ua->error; die "invite failed(call): ".$call->error if $call->error; DEBUG( "Call established (maybe), sending first file $files[0]" ); $ua->loop( \$rtp_done,\$peer_hangup,\$no_answer ); die "Ooops, no answer." if $no_answer; # mainloop until other party hangs up or we are done # send one file after the other using re-invites while ( ! $peer_hangup ) { shift(@files); # done with file @files || last; # re-invite on current call for next file DEBUG( "rtp_done=$rtp_done" ); my $rtp_done; $call->reinvite( init_media => $ua->rtp( 'send_recv', $files[0] ), cb_rtp_done => \$rtp_done, recv_bye => \$peer_hangup, # FIXME: do we need to repeat this? ); DEBUG( "sending next file $files[0]" ); $ua->loop( \$rtp_done,\$peer_hangup ); } unless ( $peer_hangup ) { # no more files: hangup my $stopvar; $call->bye( cb_final => \$stopvar ); $ua->loop( \$stopvar ); } Net-SIP-0.822/samples/dtmf.pl0000644000175100017510000000224012271424737014376 0ustar workwork use strict; use warnings; use Net::SIP; use Net::SIP::Debug; use Getopt::Long qw(:config posix_default bundling); my $debug = 100; my $from = 'sip:100@192.168.56.1'; my $to = 'sip:*69@192.168.56.101'; my $user = '100'; my $pass = 'password1234'; my $outf = 'record.raw'; my $hangup = 30; # hang up after 30 sec my $dtmf = 'ABCD*#123--4567890'; Net::SIP::Debug->level($debug); my $leg = Net::SIP::Leg->new( addr => '192.168.56.1' ); my $ua = Net::SIP::Simple->new( from => $from, auth => [ $user,$pass ], leg => $leg, ); # invite peer my $peer_hangup; # did peer hang up? my $call = $ua->invite( $to, # echo back, use -1 instead of 0 for not echoing back init_media => $ua->rtp( 'recv_echo',$outf,0 ), recv_bye => \$peer_hangup, ) || die "invite failed: ".$ua->error; die "invite failed(call): ".$call->error if $call->error; my $dtmf_done; $call->dtmf( $dtmf, cb_final => \$dtmf_done ); my $stopvar; $ua->add_timer($hangup,\$stopvar); $ua->loop( \$stopvar,\$peer_hangup,\$dtmf_done ); # timeout or dtmf done, hang up if ( $stopvar || $dtmf_done ) { $stopvar = undef; $call->bye( cb_final => \$stopvar ); $ua->loop( \$stopvar ); } Net-SIP-0.822/samples/README0000644000175100017510000000155011774636365014003 0ustar workworkThis directory contains some examples for using Net::SIP. invite_and_recv.pl - invite peer, recv RTP data and store them inside file - can register - can deal with upstream proxy - can handle authorization against proxy/registrar - see -h|--help for more information invite_and_send.pl - similar to invite_and_recv, but does send files to other party - can handle multiple files by using re-INVITEs - see -h|--help for more information test_registrar_and_proxy.pl - simple application which works as a registrar and proxy - see comments on top of the short file for more information 3pcc.pl - third party call control, e.g. invites 1st party w/o sending SDP body, invites 2nd party with SDP body from 1st and then re-INVITES 1st party with SDP from 2nd dtmf.pl - sample code on how to send dial tones (DTMF) bench/* - programs for benchmarking, see bench/README Net-SIP-0.822/tools/0000755000175100017510000000000013552315100012567 5ustar workworkNet-SIP-0.822/tools/generate-dtmf.pl0000644000175100017510000000512212271424737015664 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Getopt::Long qw(:config posix_default bundling); sub usage { print STDERR < [ 941,1336 ], '1' => [ 697,1209 ], '2' => [ 697,1336 ], '3' => [ 697,1477 ], '4' => [ 770,1209 ], '5' => [ 770,1336 ], '6' => [ 770,1477 ], '7' => [ 852,1209 ], '8' => [ 852,1336 ], '9' => [ 852,1477 ], '*' => [ 941,1209 ], '10' => [ 941,1209 ], '#' => [ 941,1477 ], '11' => [ 941,1477 ], 'A' => [ 697,1633 ], '12' => [ 697,1633 ], 'B' => [ 770,1633 ], '13' => [ 770,1633 ], 'C' => [ 852,1633 ], '14' => [ 852,1633 ], 'D' => [ 941,1633 ], '15' => [ 941,1633 ], ); my $tabsize = 256; my $volume = 100; my @costab; my @ulaw_expandtab; my @ulaw_compresstab; sub dtmftone { my $event = shift; my $f = $event2f{$event}; if ( ! $f ) { # generate silence return sub { return pack('C',128) x shift() } } if (!@costab) { for(my $i=0;$i<$tabsize;$i++) { $costab[$i] = $volume/100*16383*cos(2*$i*3.14159265358979323846/$tabsize); } for( my $i=0;$i<128;$i++) { $ulaw_expandtab[$i] = int( (256**($i/127) - 1) / 255 * 32767 ); } my $j = 0; for( my $i=0;$i<32768;$i++ ) { $ulaw_compresstab[$i] = $j; $j++ if $j<127 and $ulaw_expandtab[$j+1] - $i < $i - $ulaw_expandtab[$j]; } } my ($f1,$f2) = @$f; $f1*= $tabsize; $f2*= $tabsize; my $d1 = int($f1/$speed); my $d2 = int($f2/$speed); my $g1 = $f1 % $speed; my $g2 = $f2 % $speed; my $e1 = int($speed/2); my $e2 = int($speed/2); my $i1 = my $i2 = 0; return sub { my $len = shift; my $buf = ''; while ( $len-- > 0 ) { my $val = $costab[$i1]+$costab[$i2]; my $c = $val>=0 ? 255-$ulaw_compresstab[$val] : 127-$ulaw_compresstab[-$val]; $buf .= pack('C',$c); $e1+= $speed, $i1++ if $e1<0; $i1 = ($i1+$d1) % $tabsize; $e1-= $g1; $e2+= $speed, $i2++ if $e2<0; $i2 = ($i2+$d2) % $tabsize; $e2-= $g2; } return $buf; } } } ##### MAIN my $duration = 100; my $samples4ms = $speed/1000; for my $arg (@ARGV) { if ( $arg =~m{^-(\d+)$} ) { $duration = $1; } else { for my $ev (split('',$arg)) { my $sub = dtmftone($ev); my $samples = $duration * $samples4ms; for( my $i=0;$i<$samples;$i+=160 ) { print $sub->(160); } } } } Net-SIP-0.822/COPYRIGHT0000644000175100017510000000031011136273030012715 0ustar workworkThese modules are copyright (c) 2006-2008, Steffen Ullrich. All Rights Reserved. These modules are free software. They may be used, redistributed and/or modified under the same terms as Perl itself. Net-SIP-0.822/t/0000755000175100017510000000000013552315100011672 5ustar workworkNet-SIP-0.822/t/certs/0000755000175100017510000000000013552315100013012 5ustar workworkNet-SIP-0.822/t/certs/proxy.sip.test.pem0000644000175100017510000001203713370663710016464 0ustar workwork-----BEGIN CERTIFICATE----- MIIFPjCCAyagAwIBAgIFAMbMNzcwDQYJKoZIhvcNAQELBQAwEjEQMA4GA1UEAwwH cm9vdCBDQTAeFw0xODExMDcyMjMxMzRaFw0yODExMDQyMjMxMzRaMBkxFzAVBgNV BAMMDnByb3h5LnNpcC50ZXN0MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKC AgEA2NnktmHYL+5wjvegHuPU3VoFxqBcP17kH+0lHnSQ47xd9YAEG34tR8cs5xBR eHEFKiw1iNfwlW24w76wsxh3tESLNKSPVQ+JpbVGtGD9xLyb0sBGXZlpdKN0xvoT T6BHKsHHaRbbnd9s+DapDz9Xi19DATUJZsvzRqu9YGSmkoV5jSQFRaiwCl7BfalZ KlGdOG704/U16Fkg0rZn5hZFpGSgeqBZ7tyAVzOVA4SiIPV8MrX/JbuhM0+jzFnX I1xz63OsbWus1oRWLtDXFTNEDWEAUi2WRO5Ps3kC1vbYkD3CRa39nFyPJTYEuqgR eOishIbYb2ShzOetm2wKxXiIqEVKE0y4FWmBfBCmIF3dLIy0naND4OLX1bZIwqKA Mf/XucdUpA7ZfUS4erhQbpMy2qeU4SvXK0hOnLpBy2GCR58Qu2Kz3dKbEe+9t7ir Eh2qIjzPGeu1TxtrkUfcwLawA3bvK9icezBSxpv7Ve2PppCeC16XZgV8VnPNxFmk WB1ckmFyuUKmaU9iGJ4i1gjDHEGsBmo86k1ENobReCq3LEW9uKdjnoGAJ6TUX/wH AdQLQrALJ/HbmD/O4dL4qoKAG6WqI4CpjBjHxa7EAIFZ30MeDM3kw/ABvCW8oHMt mhbOjy+0B6sE2KQIn/4JlqGdCA71LugfrQe+MP29T7MfJIcCAwEAAaOBkzCBkDAd BgNVHQ4EFgQUA9adZYo+1YNM2WWybkQ51IUsqeMwHwYDVR0jBBgwFoAUBJ9HDSzl 2Vw6lH+DgmpcWGWtMVgwDAYDVR0TAQH/BAIwADAOBgNVHQ8BAf8EBAMCBaAwEQYJ YIZIAYb4QgEBBAQDAgbAMB0GA1UdJQQWMBQGCCsGAQUFBwMCBggrBgEFBQcDATAN BgkqhkiG9w0BAQsFAAOCAgEAZ/uUu/9kTTDsccA0r2rXkrjNWhq4UrJsNP1Y8y/p H+q7tlU3bNp+WpNyvGAR7jKlwh8f1UzdxZqxmK1gEIaAt9owMa2H3t/xDbI3DP0K r0wJvuUAYriRUpbpKKbzfhPFVY4KWN3KI/xt2lkWTA4amy/iviwlYO9ubrGBf57o H/xoLq9xhVIfNoT9QiTXTKNk3Q6gyVHIZcYS9MS8kMv+c01FmSMcahjF6ZARvdoc dPvAiuBOh6EdYbz7ygNSKllWDpYDXblUV7n6KoAtYalOLYxYU5KyC+wU0ZKJvgBx Ch5PWZG8SLyMz44CB8Tx/EJ6d3s/jkJWSoXg2LHBAwoISPYGo1JQg6PVcX3VYLYh xM8UBJfi+7DQY75rivQNOnDHZNLfjbIJZka2PfwcXjRlBAKjlj2aeccL3e30sY+r jPuHKj1V8BTRLM6SRG6jXRVfKcksAy6vanxToRCQ/5xmhnSuUgzZMzddqvmW8kXo yHkXiN0xsy140Qd7wlq41fUyLAgXjjMLKRDuLn09z1PZ76BGeEcchaFIuMFPX8S6 JVjcWPLGrgji598HK6Ym8QoYGuzGIxVqmtNa2phcCGnmn4b3dUDsQuXqZlAzeP8h HxfPCY6K+WuCF0nfYTGJPNQH33q6gbeySyWtjZV1ox6dxP7CXnYLLAsL7mJNvH5X 2ss= -----END CERTIFICATE----- -----BEGIN PRIVATE KEY----- MIIJRAIBADANBgkqhkiG9w0BAQEFAASCCS4wggkqAgEAAoICAQDY2eS2Ydgv7nCO 96Ae49TdWgXGoFw/XuQf7SUedJDjvF31gAQbfi1HxyznEFF4cQUqLDWI1/CVbbjD vrCzGHe0RIs0pI9VD4mltUa0YP3EvJvSwEZdmWl0o3TG+hNPoEcqwcdpFtud32z4 NqkPP1eLX0MBNQlmy/NGq71gZKaShXmNJAVFqLAKXsF9qVkqUZ04bvTj9TXoWSDS tmfmFkWkZKB6oFnu3IBXM5UDhKIg9Xwytf8lu6EzT6PMWdcjXHPrc6xta6zWhFYu 0NcVM0QNYQBSLZZE7k+zeQLW9tiQPcJFrf2cXI8lNgS6qBF46KyEhthvZKHM562b bArFeIioRUoTTLgVaYF8EKYgXd0sjLSdo0Pg4tfVtkjCooAx/9e5x1SkDtl9RLh6 uFBukzLap5ThK9crSE6cukHLYYJHnxC7YrPd0psR7723uKsSHaoiPM8Z67VPG2uR R9zAtrADdu8r2Jx7MFLGm/tV7Y+mkJ4LXpdmBXxWc83EWaRYHVySYXK5QqZpT2IY niLWCMMcQawGajzqTUQ2htF4KrcsRb24p2OegYAnpNRf/AcB1AtCsAsn8duYP87h 0viqgoAbpaojgKmMGMfFrsQAgVnfQx4MzeTD8AG8Jbygcy2aFs6PL7QHqwTYpAif /gmWoZ0IDvUu6B+tB74w/b1Psx8khwIDAQABAoICAQCxdMZclf9zYf3MkUoAXVNx /NxjKhGzbjTjB47ruFplc120rJkv4natmYneYRU6qcqfM2Rv4r6nmg2sah1xwmEb LUh5wPzmj/uFlq4QqJqi5/HgaqZqrEOHRsgmmLk63R/AFqnYDvOT4yXqjdiVeLFs hX1wvHVAIUCpIZutCVDi8MWCwepqkdvV8KsI6Y/lOLqfVvWioqUFygI5TToDKVC+ cfZ9w0E1Xk7MjZKxOVXwANQtL5Bn0X7eXZrefNq4vkzCbnu5Y3ciaVOZph+M4tIa 3LmFhnbFW/vvE+VGAuVATLnxiavTzE78FZOTKDx8JHQhU7REnCZoZ2NDoAvEg5nY EBf3UopRdBih3ord+j1ybXD0N3gZC4V1MSfZPhSjj8VRd2giXRP/k7PySU6JOSUO E9bYfNgX3PBByPdAiQO259QorHpBw6nxxtEY+sBAds4u9QarT2CmfcjJAZjVIhnU DJdPIASb/8r6fIJDcwIvIyj2TJnRZIbZHGbqhsves/we74SyCp5VUsBga0SGPKYm UWNfurzv10XdgPh48KwrivHdboHRyVjyjdpFzxHc9+HpTG5hhhUe3S1GMdTx7J7S w/A457GztGj1+drYkL/j1/21hkejyUNjWPZRA1t8DVcrUEAwya/KBVuTLf+vES2p a9TsuKW7GBEnzYHSxeQ74QKCAQEA97IBscyxitD2Ii+KoCDSEWQ8G+/SKuO3Aepc Yfo7zle61FM4sF+SVnW2NXjOZneuEt3edOFtUMbF9XLtg9PJAKC7RLlf2Jpb/SoB dOoQtFOcz5tQ443xMRtxna9KrX0UpghgC3pwrwY7ukLkuuBH8DHg/ZaXKyOnADV9 pOI4ufhKLFpR5/qHUMAohd3Vmqw4ubQzj5wqYh5HJPbmic2KcFMlCDpJwaoqF63f vnnR46p+Gfs2Q7QhUrHTrclJdmIxT1I1NudawBb8knuB+gW0fxHodP0K52qUNwDB qp/byk2CY/2BQhOcUEOK4+/2SWM1h58nZEFnwW2C6p1xQA8nMQKCAQEA4B8l52GA i9aDtgdwhwzVd8LDBviiu5HEKRsWoMOp8Rf4DZSrSIbP63Eo8jXaoXx18Drm1voS qRR0MDVeDGbtkrHZ785dsxJySU4EYtxdiXqKxskjJdqS3TQ6q6wjRCZuRHjvD3+N EZ8hPER7sXx9XY1UIjHatBnjhxbPCNp6in70ulTBYgybCwVXncfYuXMIq4kr/vbe K8zJ9buIbMIlWnxulpZZMBK6JJh3bCLjn6zm8XRchmJdAC15TUfWxR1GHtzf1u2B Gp1YvKjKPGxNl8HwCna6PxeCOUa3w0RnTOnerG5GeeUAwA9pHXdJ88gIPawDlXrS 3O2BKLTlig0JNwKCAQEAydACK3Cg836gHGhp5V/4aG0nwIdc0M8qa+gcj0PH+K5o LdkEpkeoPsO3ysd8O+alMQAO4WJOo/LglcSnGrKy4c0T58G2AxB5hML13uFa7OH3 MPvWIyGic6Vto9GP4dy4tzK5toBzUVed0HvySwSz+FNbgqJw1pg82CG9FluvZm6T WKHafE0WdUerfK6q/FP3/+5/2DGgIsOSqd51JbAPbMeBs7tyHtXbZ+GmHFa7GWjv R5Hzu6QHRo5W7xDCxy7oCD3t16cWvM29ykfRNfnx/1qC8Na/TJ/81PfL045eEO2o IHoLF+BMiuUNQ/xeyZqIodCd0sSrmeD1Ot0+ybfO8QKCAQAaLMkaetKugkEjsz67 Jw6PTBnG6KbozR9hxZ4g7HkehTQdMe3HLKd/0dl8YDnGfmivw9FN7irbwF3Je5Ie VK8OYOMZFLrwvQjH8uqkOSRbeApZKQiH1T0txHnNru73eJ2MNauF3dm14yXYig8A LY/eqzDWRYhLXHKsRkeruwhwwF8Im/lx4BMDeH5BGSQAlKTAk+algmN0LhiwMFTA jvQZ20p3H9wOt0EyIPRhlrmK3oCiVnqv3zEJYkY2dlto7gBQfm9OBLL9Tr8cWYI1 CFkPjkDgl/ksgSxeUBoKHiUKYI33CXIFrm8l/ybBoDrs08HSohJRFOUnlD1vaaEd PGSFAoIBAQCObryCclygZS6q6NW/M4+xLXnzG8frfYX1/FalVnSH7hMftTre98/Q i2AruJvm+yepZ7M8SUH/YaaV0FmwNIc+x9zkV0yP5x+06tGE92Y28aMYbMMwkE93 f+WJLx78b16mNNAc4qoVsb0hl9WV5pDsbuqksoybB86wY3sIAGPdE2P/cD9FfZHI CdD7NaEIV/ps/SItrkQTzC4tQcA8vimhI0AzkDyiJxxn0xx5yg5hwfow/usr58+s +gCyujIpI3NiHuVUvzfoKeu45GpwZw0t7da415ZZ6g0EQdoLUFsCLK5qCWkHA9w4 i1k+qSMfHKE6EPMQYvmvt4AjPvCTh0u7 -----END PRIVATE KEY----- Net-SIP-0.822/t/certs/ca.pem0000644000175100017510000000344613370663707014130 0ustar workwork-----BEGIN CERTIFICATE----- MIIFGTCCAwGgAwIBAgIFAPP/9L0wDQYJKoZIhvcNAQELBQAwEjEQMA4GA1UEAwwH cm9vdCBDQTAeFw0xODExMDcyMjMxMzRaFw0yODExMDQyMjMxMzRaMBIxEDAOBgNV BAMMB3Jvb3QgQ0EwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQDq8kJ4 gNSpXs/OnF5RKfYrzaMwBDpSGco6driHo0kQw0XGe7osf8hGlpOjVH55O2y4qLlQ ezuSQQqCnXRy+ZA5Je4JORQNjyznUhzSV0k0uZktqIZsK6smzMoxRHfLptyAaTXT 9X3InXAibfLP5yLAqvQuQ3GAnx5fZGBZZgkmBS2FbgxOrM254+AL35kRRedwP0dT rxmLXMFWlueMchcgA2faFmoT3fUNkTWfYVDQWtG7WzMLJ2Ki+keoFJ3sivsMacNb m2LMasg8Vcnj7wXun1DJDhjouy1ATE3ERCmrdTqeCMLD9zM+N29LjXiIwrEORso/ 5RTLGMWHrsxQLbwwOmiq6SI4CqDMWmCV7X68SyJNEDdZ3uHjq8FAQdhoK/BrM5rx te7RAhQ8/Kj7AE1CjpaTrv80pRmjJBAIfEP7r1L+Xi/0EvSYzvEdXIKmPcsaQnBq 8DCdZ8u0ZZuArZB4SFFaDnVdHR11tJOkcjXpyp1PKpeEp5HFfhgxSP3P5/JGRLbP /OjCA5HbRcWUItNLI1hcqCAD15CtXATm14TX6866Rgmdn/G2Jb0G0X/X/tka1ukV We6hHpjw9aX0HupJMBbrLBbE8V5HuX8KHqvQIcuGW9USIqaYZkAXAh9ipUDW6hvL StPcjn9hTveKVriM7u/617K3fNsjW9wEhvG9sQIDAQABo3YwdDAdBgNVHQ4EFgQU BJ9HDSzl2Vw6lH+DgmpcWGWtMVgwHwYDVR0jBBgwFoAUBJ9HDSzl2Vw6lH+Dgmpc WGWtMVgwDwYDVR0TAQH/BAUwAwEB/zAOBgNVHQ8BAf8EBAMCAoQwEQYJYIZIAYb4 QgEBBAQDAgAHMA0GCSqGSIb3DQEBCwUAA4ICAQC1E/3HztkAMYGDS35yBjd4LrdM zy+92D8DYLi9FYjF3CaReeBeCpCsM+4T57NeAcNbtDAkfCMd90W0OS+9+HAZL9Gp sTuF2dvcdNyx26brtUzkWRnh7v9UvITlNGBw+dYl3aj6wao6GY14B8p+f1wIqEaK meRHUA+IpoOm0xk+R4Dj/XFHMN5sV5cMoL8z1Wj1PRYy7AmHB1XJLZAzO6/xfxZM +jL8ljolDL+h4EzJ+5WXr4QsbmyBp6nQ/AhrOLnZQXEwuS28GkfOsEj6HvEiD5te LfhA+PXQzbNnJUbfxgA8DUJUM6VfvyXyEHcQ+7vkJXjfwUfY6pFnmOQXYXcp/7W+ xV7ynuNqeLseFry1VjryjQ7NN08HW+DDNbixeFshvZtkYD5M/EezoCHthZwzhHAe Nc4mELCQzw5Q6AU6d9Kb7WR6RFoH2Kx5tNlCODw+AA5BzPB9bohGhM3/qWzxDfoQ o0HyjBQb6NJ237z24UoO0YQgoLq2NPzNbOQSaE8+TJ7JNxvIfG5n64/+RH1VtvlB aInGqlnLj4e+O22YnrK5T6i24pMVNnpGCS5tXf/LMqG/X1znI9JeMLCYGnuhe9GO FwwtZpLlEaA9Vpm6ck78MTQM+L7qAdCmVZfFl8vPaimtneFwEWyTlNGowJSNteWB C7NzSmQ0X352sp8UGA== -----END CERTIFICATE----- Net-SIP-0.822/t/certs/listen.sip.test.pem0000644000175100017510000001203713370663710016601 0ustar workwork-----BEGIN CERTIFICATE----- MIIFPzCCAyegAwIBAgIFANLeb14wDQYJKoZIhvcNAQELBQAwEjEQMA4GA1UEAwwH cm9vdCBDQTAeFw0xODExMDcyMjMxMzRaFw0yODExMDQyMjMxMzRaMBoxGDAWBgNV BAMMD2xpc3Rlbi5zaXAudGVzdDCCAiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoC ggIBALk66DZnY5lXQCBncHbYAJvrqndMiGrz2FroREnAHb4mZVuOmGW5U7Lm5MEZ uM2nKv8BovWb6ORsgsGkG6ZSS+pP8tpDVkHK8s9Ngl69t0k0L5+JxC5LcImhMUw0 Vcy7ugrzKetRAVDcRK/thjrn8Jl2nCsFFZoqwVYK1dmAVnyoqCY6PrD8O+SK+Otr 6ymhO8YGrN2Qy181lJFXOjiFRvIbHd0CibpyHzOTxgjq55EQ14py8sgWfQomaoaW NL8iGVUG7MguMH9LQ4tMHuZX0OwjIUpwHOWGH8WpBhh7UteUaOM9bYziQBF3gLbw xrN10K4Aeh14pGpXhhAbme2xM6wOJxP/3GzdpWsLNB1NEs34dT9OMUNyxD4mx0N9 Ay0hcS/wahfXGdtcaFhVh2c+0jTGdteGJeuUxjrYaMPgd29l+klBD2dcRRcNI9R5 Hyy/MnZNmgShEz5DDTzk5lEBs//jF6WHUFj3qvVI7kHceX3n8EdwA4ZV7Rb+L6VB NOwNPNedabwq97c3KqPUCGpnk899FVL6N4nDFE5KxFO6YiqSy+u5YhC5bJJ7N1pD aeqwQXfbx1WC0V3dyShBzPuJWuYP9YF/7ofsaQ1zoelbDDehF8SLJSrwxqnmIF3a l1a14/cbBsyRRWvozRgEtzAwnsICy2bOPUBdi2y36dhaWbB1AgMBAAGjgZMwgZAw HQYDVR0OBBYEFAwIe84m2B2y7lsP3VuORI5sHXvPMB8GA1UdIwQYMBaAFASfRw0s 5dlcOpR/g4JqXFhlrTFYMAwGA1UdEwEB/wQCMAAwDgYDVR0PAQH/BAQDAgWgMBEG CWCGSAGG+EIBAQQEAwIGwDAdBgNVHSUEFjAUBggrBgEFBQcDAgYIKwYBBQUHAwEw DQYJKoZIhvcNAQELBQADggIBAK5oF7X2+/pIOjT03fIvRmVF4+1bnDOyrFz/x5r+ FcUT8Pe6AsTslE0QC6GAnUWk0+ll2Ru7YO7v3n5kwdmwwp4b9xd5UEMc1QhOh3VX MM5rVFbVamUxmrUNuSsrTEpBt9AUEgxnmw7ZsDpZolO7qhiPWyY6kdvt+BHDq3Mp t2rQMJGTazKKbeYUMN/93b4gxn/k//ce54GByS+llyHSLqXvHdWciW2KamDbeXK0 9Ak5mGjUXtmFRKBynRYmLPPIJknL2KuwKDljrTQ9Z0nSrUeGckgqLjfbs9KG09G3 xTbAnbXMtJYVcJsjPTx+r4OD6dTwe/r4JEAmj3Gflm1U4xfWcK+WpK0Xv5cnudaT yqqbABgQh3G6RIZ0uYYrzZ36a92CPZTLQRtl5I+RQ5tkwZ8z1eHIJ+P8p7Eb4lBB kQhZFftbu9rEZe7TkWDLNtOVNPogyQU1UzbjgQ+aqdKFJxzJgHIr0wcqcV1SSRyB U3UGiuJhH0nKCsOsePXPFSwnzGKQL8rWlwpD5w9FdtCySztIxFXp5Xavm9F4S0R4 JK1xnvFxksAIn1+NyuUspmr8L+bVBTtW9mWFuAmmRYx0vo68xyUGIL7H11gOtoQx K5B/qrYOXvc/gWBOSTaG/Koi/oa1s6BCFlhkmuwfr/mpdLdROjxwmAEKQz42hzlG J60K -----END CERTIFICATE----- -----BEGIN PRIVATE KEY----- MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQC5Oug2Z2OZV0Ag Z3B22ACb66p3TIhq89ha6ERJwB2+JmVbjphluVOy5uTBGbjNpyr/AaL1m+jkbILB pBumUkvqT/LaQ1ZByvLPTYJevbdJNC+ficQuS3CJoTFMNFXMu7oK8ynrUQFQ3ESv 7YY65/CZdpwrBRWaKsFWCtXZgFZ8qKgmOj6w/Dvkivjra+spoTvGBqzdkMtfNZSR Vzo4hUbyGx3dAom6ch8zk8YI6ueRENeKcvLIFn0KJmqGljS/IhlVBuzILjB/S0OL TB7mV9DsIyFKcBzlhh/FqQYYe1LXlGjjPW2M4kARd4C28MazddCuAHodeKRqV4YQ G5ntsTOsDicT/9xs3aVrCzQdTRLN+HU/TjFDcsQ+JsdDfQMtIXEv8GoX1xnbXGhY VYdnPtI0xnbXhiXrlMY62GjD4HdvZfpJQQ9nXEUXDSPUeR8svzJ2TZoEoRM+Qw08 5OZRAbP/4xelh1BY96r1SO5B3Hl95/BHcAOGVe0W/i+lQTTsDTzXnWm8Kve3Nyqj 1AhqZ5PPfRVS+jeJwxROSsRTumIqksvruWIQuWySezdaQ2nqsEF328dVgtFd3cko Qcz7iVrmD/WBf+6H7GkNc6HpWww3oRfEiyUq8Map5iBd2pdWteP3GwbMkUVr6M0Y BLcwMJ7CAstmzj1AXYtst+nYWlmwdQIDAQABAoICAAudxB5VUYu2SxE9K3JojXE5 0FD2/b8nV7QryMyPPc5E/ipFwQzwGG2pyULK6CoNh8bCRYP9qRdaLsESF6HQm24w YVyKyIgLwDp78+cZIrt2iF4K98CnfoFDGKJczdyvETXKliBpzhlSFwSpcreTACW/ qH+SLA6lC8bnmw2u3L2onhL3qCLVTrRAeufYtsC/mc4LcR/cCsUHyS9sNvyAbziT tsW7eQO2UHqdk9fPU4Jnefz2xH8D2gee7SNPnDM4YjpQ2tya+POitrOvrGhprXKB qX7PlSBXzvpIZVd3tHRMnF9T5ODm93mg8vOGGg/7HYEsCnx6qmT45DFyaa7cZA8U 5QXRwdaanO3cDm23Ur26x/GJt6jzimDq5AGk+YnHu8eI11FwuwQtxW0IcgTfcIRq b0wXG8UU10VoZmajGq1Q+LGo0oY9OD/j4fp/u6ogZP0+yMxcqBHTGfonYRQz1zkB wyqVO+1rnsU1uEGxsOE06wEPDGsbh8TdxmY6OTsRGenTj+1+vgcfRx0ZlYeCPkWP czZ7XRqn362RptmPqhyVDDFusFSylJcwkLie8nckgVLWvhCRtIcux4tzq1B8cEzz ldmyU063CNZdoxywsqGlQzSf5Q3GTRDHqIPG2xQPRPGSXI7dO4GLBI7EqQkEl8eT LUzoKmH5vpDjtlgKyhjBAoIBAQDju2k6knoctfIoOJ3LTVfGqQHMYjjoLIGpKRiH TctEgKmJ3sbdt3L9ZqYfzd3TEJ3eL3HQkGp2Rf18wjN6AYuX7Q/HOVVMgOmOhtkb Hs03xJp8bb34P5Vxwf2G24y+LU6NShRa1zJgLb7xglXG7T/jOS7BEGprMc48RZCX oc/js4xcpwp5ymtDkmP5HDIWTvh6uH84Wuu1Ped5j6Uoya71RNSQNKiU9sXbAAN5 HcKsexDjyyBrrPyaYiJSZWR3yvBAcwPoKJTmFx3FEBQhFIffZPRyln87KJstD3g9 X4uWa/1jwhmKfjR58z2G2XcVD7luNo/bVNk/Z8EeQctLCOn9AoIBAQDQOOu/9BgZ Cdo+BzjjiJqZlqdKrB5mAnfFcIpSkTVvd1whmf+fyX+eENgWo+dCT5zzwfIUROSd q1OtYhu0fJc2sX+kLhQSGlBd+6JwbaIsK9tVOAoGmrL1rpRd9xwn6A6Uc/oKTuEb hqDSaNgn0xGuvvIvyry+060RcD86XRbI7iQrWVzwnWwCp0ykkbYG6WomETcBy0zl NJ1MQk88x+4mwptnWspACQ9zQBwi7Tmk0gdKpWwKvazsR523LIhCeJQG5TK2ewPy Ctd8Jk4TRGci8BxETYn9ccQutT7ZNZ5hDoiFbjsTFoWiC3KFWlE8ZYoz23fOs3Mx igfkct+FB43ZAoIBAGz9M4ZhtelptoRDXFmBIYIlPoQXeg67xi40SdXviFm3jew6 30gbVQArkVPlTcWGzVcZs8nSY/FI2+FKfCJm/Ozv+r4pFUaw55ZbuSn+ms6W3Cyy xNk7bQVthy10g648trxt+MHk/eoD2r9w1iaHQy03H8YsWhIFWyODU4kOWxUpyAJL u3rAQoerVwdQ1DPTBZ6OD+zjrq0l/FM0SSH1LDOcBnMhkJECbXy7S+46LQIpP9MV UuXVe2tTjgOLHQMr78GYigUg7uoTpB687DVMwx5KDaeNmUSx0VpGbhBJWt/ZvQJy UZDzh5/ZpteT2icNSHyTxlN9DyAGQul9KZM2p+0CggEBAL9kks5OQBhDxidd3BzJ Y9HpeLxamVaKzizd1Ucv0j4zKKx6MU1emb9hHD8zSU7afxpQG4QmDz4eTTwCAhVU sGnFnd37vNcm+NhqhFVzcK3JYkJi0FRhvj21ywrUKT1FQKGUOTFgb+otRYYieQ2i JY7KVTM412VQjLSKyJONHXRz8SsnaRaCnNWTkg9zIC4aP0feawFrLbNBOZTvHoZv /6gBGXdXLLDPozP8qeAwzduCctFaXIVC87/71Cya8mSnEOmFo6e4S1ggPxIO45Uy OtsSeekOnNgpynpkfvCJKJtuEG8Vc5eIDC12+D07V5B8hRxFj0qgCDJw/fAu5uYQ m4ECggEBAIq9kmMZ/rMMz8YVUiCOrlt+4YP8Rd15jToWuX3oNb4XATmETdEzvePk 6AQXKDyqj7nYOWSWLqpGArHi4z5oyNEYONzSp90nj4MpJUXaDRTkYx8bBR9QF0ys AtiyPjMB2IBhajdClVIYl/YANg9C+CfUXCy3YBKNWcsnFVZ0cx8F87tt5y0vKOgL nAU+NSfZgo8K6SVcPr+orxn2B8JH6qyic14NOmEQCcEcGG72v0AQwLQwUSBM9UHf VvLaUPo2wrkjIL2r+OsbL9FkMTCAfij0LxG7fBoqPXexjNTtRgF84D3t490DoEuy luuCki9gU4ndOcVHQew/yc50oOcEgm4= -----END PRIVATE KEY----- Net-SIP-0.822/t/certs/caller.sip.test.pem0000644000175100017510000001203713370663707016553 0ustar workwork-----BEGIN CERTIFICATE----- MIIFPjCCAyagAwIBAgIEOafWTjANBgkqhkiG9w0BAQsFADASMRAwDgYDVQQDDAdy b290IENBMB4XDTE4MTEwNzIyMzEzNFoXDTI4MTEwNDIyMzEzNFowGjEYMBYGA1UE AwwPY2FsbGVyLnNpcC50ZXN0MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKC AgEAyJnUVv5mObB3T2ld2FEIrtgbJEAUbYBCvf1u1QhQRh3PJJ8rIpfJ7GZe9lQ0 JXEyAA0L0Zx20dIdRBQqTBNb5Dc6Kx1ujB1AeIIyej0vnT/Mm61TnnkpWPU4l+92 /ktlH3SBRa/0W3HTH2zoLRPQa6IKA/T1un/7khPILVPriT14ZPFEJEsqU0owOPcE x+U9PzrXp8kvZUnuN3aPUlb9XoyPyeDyfQyZtmQgbS0iDZF8F74HOIClZsYe43+O 0W7AwaDDXp5Vl5rz5E6RyvkWwEruYbkxHbvHF5kCnO7rK0KSFDFSxblCQCkBc1V2 Hd0ouWD0bJ2QoEF0AIh5Qqk9an+KTsaSMgd/58XwrznsFfAOtCZC8vgU0PkhDxQ1 b8VyeIwAKn4PMbC0bW0TOe1IFUhe2I0JjXuHxli00yJTKeyxb27JRORMo6VFSFnT gf10iR4pLekoAlMhN5WRJNPrar1WV1eEFLHBefjNmdqUVbaVn5Z4aDsZ7teUxEzw 0FLHhFkGjVzQGD15W7Qd3xCHt4GoNaOfTbh6ocNrgbCgsL1IZapWqIXp9tjKd1rC o9pcEsa5fd60OpreJeJWcjyLlFBFo81/b3kAo65BCuZJvMVe7LWBhyb5RUpejqRR zt5EJgPP6Jm/bMm8BnhVik5qxLiBROvt4MhekaKa7/HqDP8CAwEAAaOBkzCBkDAd BgNVHQ4EFgQU424vV4QcsLYoVFj+Xzb1OeLEAnQwHwYDVR0jBBgwFoAUBJ9HDSzl 2Vw6lH+DgmpcWGWtMVgwDAYDVR0TAQH/BAIwADAOBgNVHQ8BAf8EBAMCBaAwEQYJ YIZIAYb4QgEBBAQDAgbAMB0GA1UdJQQWMBQGCCsGAQUFBwMCBggrBgEFBQcDATAN BgkqhkiG9w0BAQsFAAOCAgEAbgCJpQi54Qz63xYeenqUZQam2I8VB+zl32cQCCgG 40Vqdwvd++UOKU6jB9PhUX0O15PT0rFU1Anmd3SFxy0bMT4sJE8KPHIEOHheVAnp AG+l8w0JcSjsRXr3IwapF9FBRPH+WBrWxulevsgqtn6+jksbRBhxca40CBq2WLLW Z7WSHd9RjtqGAcorJACe9vS+dFn/aUj8OkqNdMaZUyFS8hYFDx99qzKFXHCbKnq3 e9dx5dF0PVvlHa6473JNmV/1RDrC9S+V2YGZx5prLHW0c/qNnpzKJ1sXXIuxy/Gx rGxDG9KGhVFa3j32HfLGgMWbrwZTt3bpRfhgYd85iP1AUlgzCLDusGPXfKvmiQy0 Yk2Pbueg/YbrgK8ODr9pVsISSLLe4NgIGcrjn4b8Sqki/znsIFXnaX1/UIFCwdjV I5Qwr4/rfv0aFyRkYSzWwEvjsF81cw76BQC0SmlH8E6djrCqNocPm8i2Rqm1WJ/D K7qdmKoOzqxiL6L1fb3p4UCywhgX/b1BuGaUg5CpYW7UIPIjPcVIHTnXhrC8/+fz N25ouSYIUeHegrbp8myYMEQmluAfpg2XNjeJIstPzja5DJ7rTR41XcPVFgVPEntO jakz2B07TUHptOYHzeQbULj455afBsoRGthFqO9rH6NDvxQiDBFmF7l+/RdJhJl+ 6pY= -----END CERTIFICATE----- -----BEGIN PRIVATE KEY----- MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQDImdRW/mY5sHdP aV3YUQiu2BskQBRtgEK9/W7VCFBGHc8knysil8nsZl72VDQlcTIADQvRnHbR0h1E FCpME1vkNzorHW6MHUB4gjJ6PS+dP8ybrVOeeSlY9TiX73b+S2UfdIFFr/RbcdMf bOgtE9BrogoD9PW6f/uSE8gtU+uJPXhk8UQkSypTSjA49wTH5T0/OtenyS9lSe43 do9SVv1ejI/J4PJ9DJm2ZCBtLSINkXwXvgc4gKVmxh7jf47RbsDBoMNenlWXmvPk TpHK+RbASu5huTEdu8cXmQKc7usrQpIUMVLFuUJAKQFzVXYd3Si5YPRsnZCgQXQA iHlCqT1qf4pOxpIyB3/nxfCvOewV8A60JkLy+BTQ+SEPFDVvxXJ4jAAqfg8xsLRt bRM57UgVSF7YjQmNe4fGWLTTIlMp7LFvbslE5EyjpUVIWdOB/XSJHikt6SgCUyE3 lZEk0+tqvVZXV4QUscF5+M2Z2pRVtpWflnhoOxnu15TETPDQUseEWQaNXNAYPXlb tB3fEIe3gag1o59NuHqhw2uBsKCwvUhlqlaohen22Mp3WsKj2lwSxrl93rQ6mt4l 4lZyPIuUUEWjzX9veQCjrkEK5km8xV7stYGHJvlFSl6OpFHO3kQmA8/omb9sybwG eFWKTmrEuIFE6+3gyF6Roprv8eoM/wIDAQABAoICADImQu98qhHCDBHORafOml0b qa1mV7UIW6cjtJGNgoQE78Q4BpCfYdu3vAXZBzBVHCrnGA1PEGVkIezjHa/nJxHm vKQKt5hPt85ovjXRFhY53O0OZ9k2cR/MLlnNg/IO5zj151uEoZI64oz4rRKX4YMG /3n9w3Dcjgf26hRq5ndo5rBVoLNyFyK7aVLUbl2K8cTc8Q0BPtgTo3o6KZpsJOt+ OHQ/yF96xvLSFUk1/01lEaDd4PA/ORp4bUByo0G4bnf5uN3ut3cvRcnN2qTjoMxx 7yZ/JchJKXy8w+p30FMAUYS6z/aeWfGwTqyGsQDGSWgO1QxSV9W4h0ea1rXTmYaU 38Wsq3F7UxJBhMJLYE6Ad/cU1x7WeuWO1tGR3iJVCMTKTfnt5ISxVETBjFBU7NvD UtJ2irVEjprU+GG3SnrHY8Ai6Uy/QSAgxO+vDZpjlyc4T9yosm4Vnsy5uFFoFXot eiaUCh3JbDIGoPRA94RqlG8Riqlj1r8rbT0Ax8CVXMpgjyFeVLyUgr2LfwJul1zs XLQqWdzqmjyDfLTzTfYLeOKHYEJ2zcFrqS97XSPc+l0VlYydDSF5EQehiYZznulz dZu9Ur+mBGoRxjHXATsPRAmwVYLczf8MotecxyMZKBVRdyl0G9H2y1jwdP8CU/6a 3luBb71qCX6WkR84tQABAoIBAQDvsImkW7DP0f7iY9isus98v8CqqDMiJycoU1qb t7HEiVheSvmQiD/Iu518fByUIpfUWnaHzswMOfPbLPYUwIjh7+1uKA2D5yKqzyFz ryW5zDzbIS0JdUdjNYCbZzjkHlomOGNxJ9ScRL7bCfzsTLdwXjyoktgyigb9+rQk 91ssDX+9K59AzereArYCM3TxI4+Ufm46A94DItH3xovirP/w5tvK7z4fkJBsBgkT KtwbzdjnWoehOS4RD/nAkZaHIi+buT1XchZvGPpQvxkh5gr1hDGGkQa+ODKdmUza z36aEiBFTsygWSsgKqNKoO10vWJCSVMQrLz2S+PHKdue+3HrAoIBAQDWQFrwcgic m7KRMMdMpt7wNRVIYfEfhrmp3DLVvu00PLjhah/+DSeQlPeZUtXUMLqzSgrfxhIy PlTvOwJO4djDR2Pl+3i+LgNy4eUWLzZ+4iEFK6z9dl/PuC2YFb9uMYeLTKOtmXjH VM1Sd7FmmIi90/xV/qROj1vQ6G5v5m+yRIWmdOZmKcG6eV14+DJo/PneQ0VNY1Kj ezNUwBQN6AtmpdHeXEMKGIWHGgG1ZUrWFVGflG1zFBJxBClXgDvA0/BrECmqU2Um 12kEwONPl2mN3lddc7OffaNCPbDLB1DDBUvYTzBMUSlfHCQ+fN78YV66xBhcFChq 9wtbMj0rnbg9AoIBAQCyurxYX7rfrOJYJEX8vyxbBI2Bc/z1Gab8TfOBrB+Vwyiu 309rM/4EC8qqec3BtG3s/ivmpxDGiSxKoiM5ZDxt5b/xZVJ2qhLStbNnFRKXkjFK 4Vk49UfvNYUZ3IWyrONiHqggR6glgqmiobcE6UvcMZkfxqgKP5xpJNnRutU0azh2 ciHFbAcX14Oq7n3kFjVJcGF3R0z0n7FcBqRmucP7+dmpYG69kMnwkyuPLGWHIh78 nSgH06CDPptouec6CwbfIukX3M3XuBNnxKfT/Drtys43XstdaoBrvlVt0E3CS4Pe ypyRcQxUZxbuXkPSyimL7itPgs9BBWPrLk5DJZJTAoIBAEV3bkThpFsqvFYJC8WV oVkezPzADM8c/pvNcooNMpmqSoODxkW3/CkLs8/5pKz887vn+OifLw0tWpqKdnAf GAoQ3poV1AtNnf6ksYNk4XV4Wh50D83KkLwnyliyTHQtCPaobbV+ukNfAoeHmXRb ZpKt5fX370wtfSaaBhywCW0yfGcBJibfyRlt+lmbl7SkuVtQUmsKFiQ9cOI8uQPd Rb0NbKN9JJtkYf7w9rba1c3d8a4dEPOsAWK1Z7YgNL+LuDrubaP1ECns0/cfl1Qa ErZV7du2BPpkYQe8OtNJVu00jWfgHRfRhOl6lWHRWPdZlr5VkFRikMxFt1/lRSIc LD0CggEBAI86mgC5Scbuc7ANiS2cbgz8qrp2SP8Q73edXJNFggO9TyLLyMigK/Dz BgVwAtbKWFI2inx1l66sdxzFuT8Yqg9U7Vj+Qz/0LJlbmZ/lKYjz/PxlcOAt/fXF 8ceqJQ9gZHbbiTI9kFSGZ6gtly4hGSNeyBlzq61oD7/bzo7c+TO3YGlEXZv5eUMd HUd+jJMN7MVOJjY5C0jAYH4S2tkBgNCB2x3qcAut4SJ462humcstAZ3912w51d4Y kKTKxSd2FZPzyyMYpnutOajWKfq7f2yLqcvi5MO9q1MHV1B1McG/0Lm3vfBbMGH1 t9P/r1gjFbxEEewBzAoH7JgXRVWQMk4= -----END PRIVATE KEY----- Net-SIP-0.822/t/12_maddr.t0000644000175100017510000000641013022210466013452 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # Call does not involve transfer of RTP data ########################################################################### use strict; use warnings; use Test::More tests => 8*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP; use Net::SIP::Util ':all'; use IO::Socket; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,8; next; } note("------- test with family $family transport $transport"); # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket($transport); ok( $sock_uas, 'create UAS socket' ); # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # to sync UAC with UAS my $pid = fork(); if ( defined($pid) && $pid == 0 ) { $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } ok( $pid, "fork successful" ); close( $sock_uas ); close($write); alarm(15); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac(test_sip_uri($uas_addr), $read); ok( <$read>, "UAS finished" ); wait; } } ############################################### # UAC ############################################### sub uac { my ($peer_uri,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my ($transport, $peer_addr, $peer_port) = sip_uri2sockinfo($peer_uri); my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', leg => Net::SIP::Leg->new( sock => (create_socket($transport))[0], test_leg_args('caller.sip.test'), ) ); ok( $uac, 'UAC created' ); ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready my $ringing = 0; my $call = $uac->invite( test_sip_uri( "you.uas\@example.com:$peer_port", { maddr => $peer_addr } )); my $stop; if ( $call ) { ok( $call, 'Call established' ); $call->loop(1); $call->bye( cb_final => \$stop ); $call->loop( \$stop,10 ); } ok( $stop, 'UAS down' ); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => Net::SIP::Leg->new( sock => $sock, test_leg_args('listen.sip.test'), ) ) || die $!; print $pipe "UAS created\n"; # Listen my $call_closed; $uas->listen( cb_established => sub { diag( 'call established' ) }, cb_cleanup => sub { diag( 'call cleaned up' ); $call_closed =1; }, ); # notify UAC process that I'm listening print $pipe "UAS ready\n"; # Loop until call is closed, at most 10 seconds $uas->loop( \$call_closed, 10 ); $uas->cleanup; # done if ( $call_closed ) { print $pipe "UAS finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } } Net-SIP-0.822/t/20_channel_on_hold.t0000644000175100017510000001114213244174425015504 0ustar workwork#!/usr/bin/perl # testing behavior with inactive channels (i.e. no data receive): # - 4 audio channels are used in SDP # - UAC has channels 0,2 and 3 active, UAS channels 0,1 and 3 # - both use RTP send_recv # - expected is that UAC sends from 0,1,3 (i.e. active on UAS for receiving # traffic) but receives on 0,2,3. UAS sends on 0,2,3 and receives on 0,1,3 use strict; use warnings; use Test::More; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my @active_uac = (1,0,1,1); my @active_uas = (1,1,0,1); my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } my $testsize = 12; plan tests => $testsize*@tests; for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,$testsize; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start UAS my $uas = fork_sub( 'uas',$ssock,$caddr,$saddr ); fd_grep_ok( 'Listening',$uas ); # start UAC once UAS is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Call created',$uas ); fd_grep_ok( 'Call established',$uas ); # RTP transfer fd_grep_ok( 'Start RTP', $uac ); fd_grep_ok( 'RTP#100#', $uac ); fd_grep_ok( 'got rtp packet#100', $uac ); # BYE from UAC fd_grep_ok( 'Send BYE',$uac ); fd_grep_ok( "BYE done (@active_uas -- @active_uac)",$uac ); fd_grep_ok( "Call done (@active_uac -- @active_uas)",$uas ); } } killall(); ############################################################################# # UAC ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uac\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; # call with three channels, one inactive my $stop_rtp; my @csend = my @crecv = map { 0 } @active_uac; my ($sdp,$fd) = _create_sdp($lsock->sockhost, \@active_uac); my $call = $ua->invite( test_sip_uri("uas\@$peer"), sdp => $sdp, media_lsocks => $fd, init_media => $ua->rtp('send_recv', [\&_send_rtp, \( my $i = 0), \@csend],1, [\&_recv_rtp, \( my $j = 0), \@crecv, \$stop_rtp], ), ) or die; $ua->loop(5,\$stop_rtp); # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; $_ = $_>0 ? 1:0 for(@csend,@crecv); print "BYE done (@csend -- @crecv)\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uas\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('listen.sip.test'), ) ); # call with three channels, one inactive my $stop; my @csend = my @crecv = map { 0 } @active_uas; my ($sdp,$fd) = _create_sdp($lsock->sockhost, \@active_uas); $ua->listen( cb_create => sub { print "Call created\n"; 1 }, cb_established => sub { print "Call established\n"; 1 }, cb_cleanup => \$stop, media_lsocks => $fd, sdp => $sdp, init_media => $ua->rtp('send_recv', [\&_send_rtp, \( my $i = 0), \@csend],1, [\&_recv_rtp, \( my $j = 0), \@crecv, undef], ), ); print "Listening\n"; $ua->loop(10, \$stop); $_ = $_>0 ? 1:0 for(@csend,@crecv); print "Call done (@csend -- @crecv)\n"; $ua->cleanup; } sub _create_sdp { my ($laddr,$active) = @_; my (@media,@fd); for(@$active) { my ($port,@sock) = create_rtp_sockets($laddr); push @fd,\@sock; push @media, { port => $_ ? $port : 0, proto => 'RTP/AVP', media => 'audio', fmt => 0, } } return (Net::SIP::SDP->new({ addr => $laddr}, @media), \@fd); } sub _send_rtp { my ($iref,$count,$seq,$channel) = @_; $count->[$channel]++; $$iref++; if ( $$iref == 1 ) { print "Start RTP\n"; } elsif ( $$iref % 100 == 0 ) { # log after each seconds print "RTP#$$iref#\n"; } #DEBUG( "send packet $$iref" ); return "0123456789" x 16; } sub _recv_rtp { my ($iref,$count,$stopvar,$payload,$seq,$ts,$channel) = @_; $$iref++; DEBUG(50,"got data $$iref on $channel"); $count->[$channel]++; if ($stopvar && $$iref == 100) { print "got rtp packet#100\n"; $$stopvar = 1; } } Net-SIP-0.822/t/15_block_invite.t0000644000175100017510000000541613016115054015043 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # Call does not involve transfer of RTP data ########################################################################### use strict; use warnings; use Test::More tests => 8; use Net::SIP ':alias'; use Net::SIP::Util ':all'; use IO::Socket; use Net::SIP::Blocker; # create leg for UAS on dynamic port my $sock_uas = IO::Socket::INET->new( Proto => 'udp', LocalAddr => '127.0.0.1', LocalPort => 0, # let system pick one ); ok( $sock_uas, 'create UAS socket' ); # get address for UAS my $uas_addr = do { my ($port,$host) = unpack_sockaddr_in ( getsockname($sock_uas)); inet_ntoa( $host ).":$port" }; # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # to sync UAC with UAS my $pid = fork(); if ( defined($pid) && $pid == 0 ) { $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } ok( $pid, "fork successful" ); close( $sock_uas ); close($write); alarm(10); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac( $uas_addr,$read ); ok( <$read>, "UAS finished" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer_addr,$pipe) = @_; Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my $uac = Simple->new( from => 'me.uac@example.com', leg => scalar(create_socket_to( $peer_addr )), domain2proxy => { 'example.com' => $peer_addr }, ); ok( $uac, 'UAC created' ); my $blocking; my $call = $uac->invite( 'you.uas@example.com', cb_final => sub { my ($status,$self,%info) = @_; $blocking++ if $info{code} == 405; } ); ok( ! $uac->error, 'UAC ready' ); ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready $call->loop(\$blocking, 5); ok( $blocking,'UAC got block 405 and finished' ); # done if ( $blocking ) { print $pipe "UAC finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $leg = Leg->new( sock => $sock ); my $loop = Dispatcher_Eventloop->new; my $disp = Dispatcher->new( [ $leg ],$loop ) || die $!; print $pipe "UAS created\n"; # Blocking my $block = Net::SIP::Blocker->new( block => { 'INVITE' => 405 }, dispatcher => $disp, ); $disp->set_receiver( $block ); print $pipe "UAS ready\n"; $loop->loop(2); print $pipe "UAS finished\n"; } Net-SIP-0.822/t/07_call_on_hold.t0000644000175100017510000001321113022210371014774 0ustar workwork#!/usr/bin/perl ############################################################################# # # very similar to t/06_call_with_reinvite.t, except that the reinvite # puts the UAS on hold # - UAS listens # - UAC calls UAS # - UAS accepts call # - UAC sends some data to UAS # - after some time UAS re-invites UAC, but with c=0.0.0.0, e.g # it puts the call on hold # - UAC accepts # - UAS sends some data to UAC, UAC does not send back even if # recv_echo is used # - after a while UAC hangs up # ############################################################################# use strict; use warnings; use Test::More tests => 16*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,16; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start UAS my $uas = fork_sub( 'uas',$ssock,$caddr,$saddr ); fd_grep_ok( 'Listening',$uas ); # start UAC once UAS is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Call accepted',$uas ); # first RTP from UAC to UAS fd_grep_ok( 'Start RTP', $uac ); fd_grep_ok( 'RTP#50#', $uac ); fd_grep_ok( 'got rtp packet#50', $uas ); # then re-invite fd_grep_ok( 'Starting ReInvite', $uas ); fd_grep_ok( 'Got ReInvite', $uac ); # RTP from UAS to UAC fd_grep_ok( 'Start RTP', $uas ); fd_grep_ok( 'RTP#50#', $uas ); fd_grep_ok( 'got rtp packet#50', $uac ); # BYE from UAC # UAS should not receive anything fd_grep_ok( 'Send BYE',$uac ); fd_grep_ok( 'Received BYE after 0 bytes read',$uas ); fd_grep_ok( 'BYE done',$uac ); } } killall(); ############################################################################# # UAC ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uac\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; # call and transfer data until I get reinvite # then change RTP handling to recv_echo and stop after 50 packets my ($reinvite,$stop_rtp50); my $switch_media_on_reinvite = sub { my ($ok,$call) = @_; DEBUG( "switch media" ); $call->set_param( init_media => $call->rtp( 'recv_echo', [ \&_recv_rtp, \( my $i=0 ), \$stop_rtp50 ] ), ); $reinvite = 1; }; my $call = $ua->invite( test_sip_uri("uas\@$peer"), init_media => $ua->rtp( 'send_recv', [ \&_send_rtp, \( my $i = 0) ] ), cb_established => $switch_media_on_reinvite, clear_sdp => 1, # don't reuse sockets from last RTP session ) || die; # wait for reinvite done $ua->loop( 10,\$reinvite ); $reinvite || die; print "Got ReInvite\n"; # wait until 50 packets received from the new connection $ua->loop( 5,\$stop_rtp50 ); # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uas\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('listen.sip.test'), ) ); # accept call and send some data, set $stop once # the call was established my $stop = 0; my $stop_rtp50 = 0; my $call; my $init_media_recv = sub { (undef,$call) = @_; DEBUG( "accepted call" ); $call->set_param( init_media => $call->rtp( 'recv_echo', [ \&_recv_rtp, \( my $i=0 ), \$stop_rtp50 ],-1 ) ); $stop = 1; }; $ua->listen( cb_established => $init_media_recv ); print "Listening\n"; $ua->loop( \$stop ); print "Call accepted\n"; # wait until I got 50 packets $ua->loop( \$stop_rtp50 ); # Reinvite and send data until I get BYE print "Starting ReInvite\n"; my $bytes = 0; my $write_bytes = sub { $bytes += length($_[0]) }; my $recv_bye = 0; my $init_media_send = sub { my ($ok,$call) = @_; DEBUG( "init media because re-invite was $ok" ); $stop = 1; $ok eq 'OK' or die; $call->set_param( init_media => $call->rtp( 'send_recv', [ \&_send_rtp, \( my $i=0 ) ], 1, $write_bytes, ), recv_bye => \$recv_bye, ); }; $stop = 0; $call->reinvite( clear_sdp => 1, cb_final => $init_media_send, call_on_hold => 1, ); # wait until INVITE succeeds $ua->loop( 10,\$stop ); print "ReInvite succeeded\n" if $stop eq 'OK'; print "ReInvite FAILED\n" if $stop eq 'FAIL'; # wait until I got BYE $ua->loop( 10, \$recv_bye ); print "Received BYE after $bytes bytes read\n" if $recv_bye; # make sure the reply for the BYE makes it on the wire $ua->loop(1); $ua->cleanup; } sub _send_rtp { my $iref = shift; $$iref++; if ( $$iref == 1 ) { print "Start RTP\n"; } elsif ( $$iref % 50 == 0 ) { # log after each seconds print "RTP#$$iref#\n"; } #DEBUG( "send packet $$iref" ); return "0123456789" x 16; } sub _recv_rtp { my ($iref,$stopvar,$payload) = @_; $$iref++; #DEBUG( 50,"got data $$iref" ); if ( $$iref == 50 ) { print "got rtp packet#50\n"; $$stopvar = 1; } } Net-SIP-0.822/t/17_call_with_reinvite_and_auth.t0000644000175100017510000000546713022210565020121 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Test::More tests => 11*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,11; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start UAS my $uas = fork_sub( 'uas',$ssock,$caddr,$saddr ); fd_grep_ok( 'Listening',$uas ); # start UAC once UAS is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Call accepted',$uas ); # then re-invite fd_grep_ok( 'Starting ReInvite', $uac ); fd_grep_ok( 'ReInvite accepted',$uas ); fd_grep_ok( 'ReInvite done', $uac ); # BYE from UAC fd_grep_ok( 'Send BYE',$uac ); fd_grep_ok( 'Received BYE',$uas ); fd_grep_ok( 'BYE done',$uac ); } } killall(); ############################################################################# # UAC ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Net::SIP::Simple->new( from => 'me\@$laddr', auth => [ 'me','secret' ], leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; my $call = $ua->invite(test_sip_uri("me\@$peer")) or die; sleep(1); print "Starting ReInvite\n"; my $reinvite_ok; $call->reinvite( cb_final => \$reinvite_ok ) or die; $ua->loop( 10,\$reinvite_ok ); print "ReInvite done\n" if $reinvite_ok; sleep(1); # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Net::SIP::Simple->new( from => "me\@$laddr", leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('listen.sip.test'), ) ) || die $!; # accept call my $invite = my $reinvite = my $bye = 0; $ua->listen( auth_user2pass => { 'me' => 'secret' }, cb_established => sub { $reinvite++ if $invite++ }, cb_cleanup => \$bye, ); print "Listening\n"; $ua->loop( \$invite ); print "Call accepted\n"; $ua->loop( \$reinvite ); print "ReInvite accepted\n"; # wait until I got BYE $ua->loop( 10, \$bye ); $ua->cleanup; print "Received BYE\n" if $bye; } Net-SIP-0.822/t/11_invite_timeout.t0000644000175100017510000000732313022210452015425 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # Call does not involve transfer of RTP data # UAS will on ring, but never 200 Ok, UAC will cancel call ########################################################################### use strict; use warnings; use Test::More tests => 8*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP; use Net::SIP::Util ':all'; use IO::Socket; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,8; next; } note("------- test with family $family transport $transport"); # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket($transport); ok( $sock_uas, 'create UAS socket' ); # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # to sync UAC with UAS my $pid = fork(); if ( defined($pid) && $pid == 0 ) { $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } ok( $pid, "fork successful" ); close( $sock_uas ); close($write); alarm(15); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac(test_sip_uri($uas_addr), $read); ok( <$read>, "done" ); wait; } } ############################################### # UAC ############################################### sub uac { my ($peer_uri,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my ($transport) = sip_uri2sockinfo($peer_uri); my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', domain2proxy => { 'example.com' => $peer_uri }, leg => Net::SIP::Leg->new( sock => (create_socket($transport))[0], test_leg_args('caller.sip.test'), ) ); ok( $uac, 'UAC created' ); ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready my $call_ok = 0; my $end_code; my $call = $uac->invite( 'you.uas@example.com', cb_final => sub { my ($status,$self,%info) = @_; $end_code = $info{code}; }, ); $uac->loop(3,\$call_ok); ok($call_ok == 0,'invite did not complete'); $call->cancel; $uac->loop(3,\$end_code); ok( $end_code==487,'got 487 (request canceled)'); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => Net::SIP::Leg->new( sock => $sock, test_leg_args('listen.sip.test'), ) ) || die $!; print $pipe "UAS created\n"; my $timer; my $got_cancel; my $my_receive = sub { my ($self,$endpoint,$ctx,$error,$code,$packet,$leg,$from) = @_; if ( $packet->is_request && $packet->method eq 'INVITE' ) { # just ring my $ring = $packet->create_response( 180,'Ringing' ); $timer ||= $endpoint->{dispatcher}->add_timer( 1, sub { $endpoint->new_response( $ctx,$ring,$leg,$from ) }, 1 ); return; } if ( $timer && $packet->is_request && $packet->method eq 'CANCEL' ) { $timer->cancel; $got_cancel =1; } goto &Net::SIP::Simple::Call::receive; }; # Listen $uas->listen( cb_create => sub { return $my_receive } ); # notify UAC process that I'm listening print $pipe "UAS ready\n"; # Loop at most 10 seconds $uas->loop( 10,\$got_cancel ); $uas->loop( 3 ); $uas->cleanup; print $pipe "UAS done\n"; } Net-SIP-0.822/t/19_call_with_dtmf.t0000644000175100017510000001240213142324431015351 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # transfer RTP data during call, then hang up ########################################################################### use strict; use warnings; use Test::More tests => 9*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use IO::Socket; use File::Temp; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,9; next; } note("------- test with family $family transport $transport"); # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket($transport); diag( "UAS on $uas_addr" ); # fork UAS and make call from UAC to UAS pipe( my $from_uas,my $to_uac); # for status updates defined( my $pid = fork() ) || die $!; if ( $pid == 0 ) { # CHILD = UAS $SIG{ __DIE__ } = undef; close($from_uas); $to_uac->autoflush; uas( $sock_uas, $to_uac ); exit(0); } # PARENT = UAC close($sock_uas); close($to_uac); alarm(60); local $SIG{__DIE__} = sub { kill 9,$pid; ok( 0,'died' ) }; local $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'timed out' ) }; uac(test_sip_uri($uas_addr), $from_uas); my $uas = <$from_uas>; killall(); is( $uas, "UAS finished events=1 2 D # 3 4 B *\n", "UAS finished with DTMF" ); } } ############################################### # UAC ############################################### sub uac { my ($peer_uri,$from_uas) = @_; Debug->set_prefix( "DEBUG(uac):" ); # line noise when no DTMF is sent my $packets = 250; # 5 seconds my $send_something = sub { return unless $packets-- > 0; my $buf = sprintf "%010d",$packets; $buf .= "1234567890" x 15; return $buf; # 160 bytes for PCMU/8000 }; # create Net::SIP::Simple object my $rtp_done; my ($transport) = sip_uri2sockinfo($peer_uri); my ($lsock,$laddr) = create_socket($transport); diag( "UAC on $laddr" ); my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', domain2proxy => { 'example.com' => $peer_uri }, leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); ok( $uac, 'UAC created' ); # wait until UAS is ready and listening my $uas = <$from_uas>; is( $uas, "UAS ready\n","UAS ready" ); # Call UAS my @events; my $call = $uac->invite( test_sip_uri('you.uas@example.com'), init_media => $uac->rtp( 'send_recv', $send_something ), cb_rtp_done => \$rtp_done, cb_dtmf => sub { push @events,shift; } ); ok( ! $uac->error, 'no error on UAC' ); ok( $call, 'Call established' ); $call->dtmf('12D#',methods => 'rfc2833', duration => 500); $call->dtmf('34B*',methods => 'audio', duration => 500); $call->loop( \$rtp_done, 20 ); ok( $rtp_done, "Done sending RTP" ); my $stop; $call->bye( cb_final => \$stop ); $call->loop( \$stop,30 ); ok( $stop, 'UAS down' ); $uas = <$from_uas>; like($uas, qr/UAS RTP ok/, "UAS RTP ok"); # DTMF echoed back is( "@events","1 2 D # 3 4 B *", "UAC DTMF received"); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$to_uac) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => Net::SIP::Leg->new( sock => $sock, test_leg_args('listen.sip.test'), ) ) || die $!; # count received RTP data my $received = my $lost = my $lastseq = 0; my $save_rtp = sub { my ($buf,$seq) = @_; #warn substr( $buf,0,10)."\n"; my $diff = $seq - $lastseq; if ($diff == 0) { diag("duplicate $seq"); next; } elsif ($diff<0) { diag("out of order $seq"); next; } if ($diff>1) { $lost += $diff-1; diag(sprintf("lost %d packets (%d-%d)", $diff-1,$lastseq+1,$seq-1)); } $received++; $lastseq = $seq; }; # Listen my ($call_closed,@events); $uas->listen( cb_create => sub { diag( 'call created' );1 }, cb_established => sub { diag( 'call established' );1 }, cb_cleanup => sub { diag( 'call cleaned up' ); $call_closed =1; }, init_media => $uas->rtp( 'recv_echo', $save_rtp ), cb_dtmf => sub { push @events,shift } ); # notify UAC process that I'm listening print $to_uac "UAS ready\n"; # Loop until call is closed, at most 20 seconds $uas->loop( \$call_closed, 20 ); $uas->cleanup; # 5 seconds line noise, 8 events a 500 ms and some pause in between my $xrtpc = 5*50 + 8*25 + 7*2.5; diag("received=$received lost=$lost expect ca. $xrtpc packets, events='@events'"); # at least 20% of all RTP packets should come through if ( $received > $xrtpc * 0.8) { print $to_uac "UAS RTP ok ($received,$lost)\n" } else { print $to_uac "UAS RTP received only $received/$xrtpc packets, lost $lost\n"; } # done if ( $call_closed ) { print $to_uac "UAS finished events=@events\n"; } else { print $to_uac "call closed by timeout not stopvar\n"; } } Net-SIP-0.822/t/21_channel_on_hold_stateless_proxy.t0000644000175100017510000002016013371560763021042 0ustar workwork#!/usr/bin/perl # testing behavior with inactive channels (i.e. no data receive) and Proxy # like 20_channel_on_hold.t, only with proxy + NAT-helper in between use strict; use warnings; use Test::More; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Net::SIP::NATHelper::Local; use Net::SIP::NATHelper::Server; use Net::SIP::NATHelper::Client; my @active_uac = (1,0,1,1); my @active_uas = (1,1,0,1); my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { for my $nat ('no-nat', 'inline-nat', 'remote-nat') { push @tests, [ $transport, $family, $nat ]; } } } my $testsize = 20; plan tests => $testsize*@tests; for my $t (@tests) { my ($transport,$family,$nat) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,$testsize; next; } note("------- test with family $family transport $transport $nat"); do_test($transport,$nat) } } killall(); sub do_test { my ($transport,$natspec) = @_; my ($luac,$luas,@lproxy); for ( [ 'caller.sip.test', \$luac ], [ 'listen.sip.test', \$luas ], [ 'proxy.sip.test', \$lproxy[0] ], [ 'proxy.sip.test', \$lproxy[1] ], ) { my ($name,$config) = @$_; my ($sock,$addr) = create_socket($transport); $$config = { name => $name, sock => $sock, addr => $addr, uri => test_sip_uri($addr), }; } note( "UAS on $luas->{addr} " ); note( "UAC on $luac->{addr} " ); note( "PROXY on $lproxy[0]{addr} $lproxy[1]{addr} " ); # restrict legs of proxy so that packets gets routed even # if all is on the same interface. Enable dumping on # incoing and outgoing packets to check NAT for ( $luac,$luas,$lproxy[0],$lproxy[1] ) { $_->{leg} = TestLeg->new( sock => $_->{sock}, dump_incoming => [ \&sip_dump_media,'I<' ], dump_outgoing => [ \&sip_dump_media,'O>' ], $_ == $lproxy[0] ? ( can_deliver_to => $luac->{addr} ) :(), $_ == $lproxy[1] ? ( can_deliver_to => $luas->{addr} ) :(), test_leg_args($_->{name}), ); } # socket for nathelper server my ($nath_sock,$nath_addr) = create_socket('tcp') or die $!; my $natcb; if ( $natspec eq 'inline-nat' ) { $natcb = sub { NATHelper_Local->new( shift ) }; ok(1,'no fork nathelper'); } elsif ( $natspec eq 'remote-nat' ) { fork_sub( 'nathelper',$nath_sock ); $natcb = sub { NATHelper_Client->new( $nath_addr ) } } else { ok(1,'no fork nathelper'); } # start proxy and UAS and wait until they are ready my $proxy = fork_sub( 'proxy', @lproxy,$luas->{uri},$natcb ); my $uas = fork_sub( 'uas', $luas ); fd_grep_ok( 'ready',10,$proxy ) || die; fd_grep_ok( 'ready',10,$uas ) || die; # UAC: invite and transfer RTP data my $uac = fork_sub( 'uac', $luac, $lproxy[0]{uri} ); fd_grep_ok( 'ready',10,$uac ) || die; my $uac_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},5,$uac ) || die; my $pin_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},5,$proxy ) || die; my $pout_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},1,$proxy ) || die; my $uas_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},1,$uas ) || die; s{.*audio=}{} for ( $uac_invite,$pin_invite,$pout_invite,$uas_invite ); # check for NAT ok( $uac_invite eq $pin_invite, "outgoing on UAC must be the same as incoming on proxy" ); ok( $pout_invite eq $uas_invite, "outgoing on proxy must be the same as incoming on UAS" ); if ( $natspec eq 'no-nat' ) { ok( $uac_invite eq $uas_invite, "SDP must pass unchanged to UAS" ); ok(1,'dummy'); } else { # get port/range and compare my ($sock_i,$range_i) = split( m{/},$pin_invite,2 ); my ($sock_o,$range_o) = split( m{/},$pout_invite,2 ); ok( $sock_i ne $sock_o, "allocated addr:port must be different ($sock_i|$sock_o)" ); ok( $range_i == $range_o, "ranges must stay the same" ); } # top via must be from lproxy[1], next via from UAC # this is to show that the request went through the proxy fd_grep_ok( 'call created',10,$uas ); fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $lproxy[1]{addr};}i,1,$uas ); fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $luac->{addr};}i,1,$uas ); # done fd_grep_ok( "BYE done (@active_uas -- @active_uac)",$uac ); fd_grep_ok( "Call done (@active_uac -- @active_uas)",$uas ); killall(); } killall(); ############################################################################# # Proxy ############################################################################# sub proxy { my ($lsock_c,$lsock_s,$proxy_uri,$natcb) = @_; # need loop separately my $loop = Dispatcher_Eventloop->new; my $nathelper = invoke_callback( $natcb,$loop ); # create Net::SIP::Simple object my $proxy = Simple->new( loop => $loop, legs => [ $lsock_c->{leg}, $lsock_s->{leg} ], domain2proxy => { 'example.com' => $proxy_uri }, ); $proxy->create_stateless_proxy( nathelper => $nathelper ); print "ready\n"; $proxy->loop; } ############################################################################# # UAC ############################################################################# sub uac { my ($leg,$proxy_uri) = @_; my $ua = Simple->new( from => 'me.uac@example.com', leg => $leg->{leg}, outgoing_proxy => $proxy_uri, ); print "ready\n"; # call with three channels, one inactive my $stop_rtp; my @csend = my @crecv = map { 0 } @active_uac; my ($sdp,$fd) = _create_sdp($leg->{sock}->sockhost, \@active_uac); my $call = $ua->invite('you.uas@example.com', sdp => $sdp, media_lsocks => $fd, init_media => $ua->rtp('send_recv', [\&_send_rtp, \( my $i = 0), \@csend],1, [\&_recv_rtp, \( my $j = 0), \@crecv, \$stop_rtp], ), ) or die; $ua->loop(5,\$stop_rtp); # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; $_ = $_>0 ? 1:0 for(@csend,@crecv); print "BYE done (@csend -- @crecv)\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($leg) = @_; my $ua = Simple->new( domain => 'example.com', leg => $leg->{leg} ) || die $!; # call with three channels, one inactive my $stop; my @csend = my @crecv = map { 0 } @active_uas; my ($sdp,$fd) = _create_sdp($leg->{sock}->sockhost, \@active_uas); $ua->listen( cb_create => sub { my ($call,$request) = @_; print "call created\n"; print $request->as_string; 1; }, cb_established => sub { print "call established\n"; 1 }, cb_cleanup => \$stop, media_lsocks => $fd, sdp => $sdp, init_media => $ua->rtp('send_recv', [\&_send_rtp, \( my $i = 0), \@csend],1, [\&_recv_rtp, \( my $j = 0), \@crecv, undef], ), ); print "ready\n"; $ua->loop(10, \$stop); $_ = $_>0 ? 1:0 for(@csend,@crecv); print "Call done (@csend -- @crecv)\n"; $ua->cleanup; } sub _create_sdp { my ($laddr,$active) = @_; my (@media,@fd); for(@$active) { my ($port,@sock) = create_rtp_sockets($laddr); push @fd,\@sock; push @media, { port => $_ ? $port : 0, proto => 'RTP/AVP', media => 'audio', fmt => 0, } } return (Net::SIP::SDP->new({ addr => $laddr}, @media), \@fd); } sub _send_rtp { my ($iref,$count,$seq,$channel) = @_; $count->[$channel]++; $$iref++; if ( $$iref == 1 ) { print "Start RTP\n"; } elsif ( $$iref % 100 == 0 ) { # log after each seconds print "RTP#$$iref#\n"; } #DEBUG( "send packet $$iref" ); return "0123456789" x 16; } sub _recv_rtp { my ($iref,$count,$stopvar,$payload,$seq,$ts,$channel) = @_; $$iref++; DEBUG(50,"got data $$iref on $channel"); $count->[$channel]++; if ($stopvar && $$iref == 100) { print "got rtp packet#100\n"; $$stopvar = 1; } } # -------------------------------------------------------------- # NATHelper::Server # -------------------------------------------------------------- sub nathelper { my $sock = shift; NATHelper_Server->new( $sock )->loop; } Net-SIP-0.822/t/08_register_with_auth.t0000644000175100017510000001016213022210431016257 0ustar workwork#!/usr/bin/perl ############################################################################# # test Authorize in front of Registrar inside a ReceiveChain # to authorize REGISTER requests ############################################################################# use strict; use warnings; use Test::More tests => 7*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Digest::MD5 'md5_hex'; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,7; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start Registrar my $registrar = fork_sub( 'registrar',$ssock,$saddr ); fd_grep_ok( 'Listening',$registrar ); # start UAC once Registrar is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Registered wolf (REALM.example.com)',$uac ); fd_grep_ok( 'Registered 007 (REALM.example.com)',$uac ); fd_grep_ok( 'Registered noauth ()',$uac ); } } killall(); ############################################################################# # UAC # Try to register me@example.com with auth wolf:lobo and 007:secret. # In both cases authorization should be required. # Then register noauth@example.com in which case no authorization should # be required (see sub registrar) # auth is done with callback so that we see if the authorization was required ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri('me@example.com'), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; my $realm = ''; $ua->register( registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ 'wolf','lobo' ], }, ) || die; print "Registered wolf ($realm)\n"; $realm = ''; $ua->register( registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; print "Registered 007 ($realm)\n"; $realm = ''; $ua->register( from => test_sip_uri('noauth@example.com'), registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; print "Registered noauth ($realm)\n"; $ua->cleanup; } ############################################################################# # Registrar with Authorize in front # The $auth_chain consists of an ReceiveChain with a Authorize object # inside. The ReceiveChain has a filter so that only requests with # contact info !~ noauth\@ will be forwarded to the Authorize object # Then $auth_chain is put in front of the Registrar object into a chain # which then handles all packets # The result is, that all requests must be authorized, except the ones # where contact matches noauth\@ ############################################################################# sub registrar { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('proxy.sip.test'), ) ); my $auth = Authorize->new( dispatcher => $ua->{dispatcher}, user2a1 => { '007' => md5_hex('007:REALM.example.com:secret') }, user2pass => sub { $_[0] eq 'wolf' ? 'lobo' : 'no-useful-password' }, realm => 'REALM.example.com', opaque => 'HumptyDumpty', i_am_proxy => 0, ); my $auth_chain = ReceiveChain->new( [ $auth ], filter => sub { my ($packet,$leg,$from) = @_; # no auth for responses and noauth@... return if $packet->is_response; my $need_auth = $packet->get_header( 'contact' ) !~m{noauth\@}; return $need_auth; } ); my $reg = Registrar->new( dispatcher => $ua->{dispatcher}, domain => 'example.com', ); $ua->create_chain( [ $auth_chain,$reg ] ); print "Listening\n"; $ua->loop } Net-SIP-0.822/t/06_call_with_reinvite.t0000644000175100017510000001263313022210343016237 0ustar workwork#!/usr/bin/perl ############################################################################# # # - UAS listens # - UAC calls UAS # - UAS accepts call # - UAC sends some data to UAS # - after some time UAS re-invites UAC # - UAC accepts # - UAS sends some data to UAC # - after a while UAC hangs up # ############################################################################# use strict; use warnings; use Test::More tests => 17*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,17; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start UAS my $uas = fork_sub( 'uas',$ssock,$caddr,$saddr ); fd_grep_ok( 'Listening',$uas ); # start UAC once UAS is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Call accepted',$uas ); # first RTP from UAC to UAS fd_grep_ok( 'Start RTP', $uac ); fd_grep_ok( 'RTP#50#', $uac ); fd_grep_ok( 'got rtp packet#50', $uas ); # then re-invite fd_grep_ok( 'Starting ReInvite', $uas ); fd_grep_ok( 'Got ReInvite', $uac ); # RTP from UAS to UAC fd_grep_ok( 'Start RTP', $uas ); fd_grep_ok( 'RTP#50#', $uas ); fd_grep_ok( 'got rtp packet#50', $uac ); # BYE from UAC fd_grep_ok( 'Send BYE',$uac ); fd_grep_ok( 'Got RTP',$uas ); fd_grep_ok( 'Received BYE',$uas ); fd_grep_ok( 'BYE done',$uac ); } } killall(); ############################################################################# # UAC ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uac\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; # call and transfer data until I get reinvite # then change RTP handling to recv_echo and stop after 50 packets my ($reinvite,$stop_rtp50); my $switch_media_on_reinvite = sub { my ($ok,$call) = @_; DEBUG( "switch media" ); $call->set_param( init_media => $call->rtp( 'recv_echo', [ \&_recv_rtp, \( my $i=0 ), \$stop_rtp50 ] ), ); $reinvite = 1; }; my $call = $ua->invite( test_sip_uri("uas\@$peer"), init_media => $ua->rtp( 'send_recv', [ \&_send_rtp, \( my $i = 0) ] ), cb_established => $switch_media_on_reinvite, clear_sdp => 1, # don't reuse sockets from last RTP session ) || die; # wait for reinvite done $ua->loop( 10,\$reinvite ); $reinvite || die; print "Got ReInvite\n"; # wait until 50 packets received from the new connection $ua->loop( 5,\$stop_rtp50 ); # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri("uas\@$laddr"), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('listen.sip.test'), ) ); # accept call and send some data, set $stop once # the call was established my $stop = 0; my $stop_rtp50 = 0; my $call; my $init_media_recv = sub { (undef,$call) = @_; DEBUG( "accepted call" ); $call->set_param( init_media => $call->rtp( 'recv_echo', [ \&_recv_rtp, \( my $i=0 ), \$stop_rtp50 ],-1 ) ); $stop = 1; }; $ua->listen( cb_established => $init_media_recv ); print "Listening\n"; $ua->loop( \$stop ); print "Call accepted\n"; # wait until I got 50 packets $ua->loop( \$stop_rtp50 ); # Reinvite and send data until I get BYE print "Starting ReInvite\n"; my $bytes = 0; my $write_bytes = sub { $bytes += length($_[0]) }; my $recv_bye = 0; my $init_media_send = sub { my ($ok,$call) = @_; DEBUG( "init media because re-invite was $ok" ); $stop = 1; $ok eq 'OK' or die; $call->set_param( init_media => $call->rtp( 'send_recv', [ \&_send_rtp, \( my $i=0 ) ], 1, $write_bytes ), recv_bye => \$recv_bye, ); }; $stop = 0; $call->reinvite( clear_sdp => 1, cb_final => $init_media_send, ); # wait until INVITE succeeds $ua->loop( 10,\$stop ); print "ReInvite succeeded\n" if $stop eq 'OK'; print "ReInvite FAILED\n" if $stop eq 'FAIL'; # wait until I got BYE $ua->loop( 10, \$recv_bye ); print "Got RTP\n" if $bytes; print "Received BYE\n" if $recv_bye; # make sure the reply for the BYE makes it on the wire $ua->loop(1); $ua->cleanup; } sub _send_rtp { my $iref = shift; $$iref++; if ( $$iref == 1 ) { print "Start RTP\n"; } elsif ( $$iref % 50 == 0 ) { # log after each seconds print "RTP#$$iref#\n"; } #DEBUG( "send packet $$iref" ); return "0123456789" x 16; } sub _recv_rtp { my ($iref,$stopvar,$payload) = @_; $$iref++; #DEBUG( 50,"got data $$iref" ); if ( $$iref == 50 ) { print "got rtp packet#50\n"; $$stopvar = 1; } } Net-SIP-0.822/t/14_bugfix_0.51.t0000644000175100017510000000663513022210511014314 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Net::SIP::SDP; use Data::Dumper; my $HOST = '127.0.0.1'; my ($luac,$luas,$lproxy); for ( $luac,$luas,$lproxy) { my ($sock,$addr) = create_socket_to( $HOST ); $_ = { sock => $sock, addr => $addr }; } diag( "UAS on $luas->{addr} " ); diag( "UAC on $luac->{addr} " ); diag( "PROXY on $lproxy->{addr} " ); # start Proxy my $proxy = fork_sub( 'proxy', $lproxy ); fd_grep_ok( 'Listening',$proxy ); # start UAS my $uas = fork_sub( 'uas', $luas, $lproxy->{addr} ); fd_grep_ok( 'Listening',$uas ); # start UAC once UAS is ready my $uac = fork_sub( 'uac', $luac, $lproxy->{addr} ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'Call accepted',$uas ); # then re-invite fd_grep_ok( 'Starting ReInvite', $uas ); fd_grep_ok( 'Got ReInvite', $uac ); # BYE from UAS fd_grep_ok( 'Send BYE',$uas ); fd_grep_ok( 'Received BYE',$uac ); fd_grep_ok( 'BYE done',$uas ); killall(); # -------------------------------------------------------------- # PROXY # -------------------------------------------------------------- sub proxy { my $lsock = shift; my $proxy = Net::SIP::Simple->new( leg => $lsock ); $proxy->create_chain([ $proxy->create_registrar, $proxy->create_stateless_proxy, ]); print "Listening\n"; $proxy->loop; } # -------------------------------------------------------------- # UAC # -------------------------------------------------------------- sub uac { my ($lsock,$paddr) = @_; my $ua = Simple->new( leg => $lsock, outgoing_proxy => $paddr, from => "sip:uac\@$paddr", ); print "Started\n"; my ($call,$reinvite); $ua->invite( "sip:uas\@$paddr", cb_established => sub { (undef,$call) = @_; $reinvite = 1; }) || die; # wait for reinvite done $reinvite = 0; $ua->loop( 10,\$reinvite ); $reinvite || die; print "Got ReInvite\n"; # wait for BYE $call->set_param( recv_bye => \( my $recv_bye )); $ua->loop( 5,\$recv_bye ); $ua->cleanup; print "Received BYE\n" if $recv_bye; } # -------------------------------------------------------------- # UAS # -------------------------------------------------------------- sub uas { my ($lsock,$paddr) = @_; my $ua = Simple->new( domain => $paddr, registrar => $paddr, outgoing_proxy => $paddr, leg => $lsock, from => "sip:uas\@$paddr", ); # registration $ua->register; die "registration failed: ".$ua->error if $ua->error; # accept call and send some data, set $stop once # the call was established my $stop = 0; my $call; $ua->listen( cb_established => sub { (undef,$call) = @_; $stop = 1 }); print "Listening\n"; $ua->loop( \$stop ); print "Call accepted\n"; # Reinvite print "Starting ReInvite\n"; $stop = 0; $call->reinvite( cb_final => \$stop ); $ua->loop( 10,\$stop ); # Bug fixed in 0.51: # to of context should be uas, from should be uac, context should be incoming die "from is $call->{ctx}{from}" if $call->{ctx}{from} !~m{uac\@}; die "from is $call->{ctx}{to}" if $call->{ctx}{to} !~m{uas\@}; die "ctx is not incoming" if ! $call->{ctx}{incoming}; # and bye print "Send BYE\n"; $call->bye( cb_final => \( my $bye_ok )); $ua->loop( 10,\$bye_ok ); $ua->cleanup; print "BYE done\n" if $bye_ok; } Net-SIP-0.822/t/23_valid_message.t0000644000175100017510000000427313431274222015201 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Test::More; use Net::SIP::Packet; use Net::SIP::Request; use Net::SIP::Response; check(undef, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 10 INVITE Content-length: 0 REQ check(qr/method in cseq does not match method of request/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 10 BYE Content-length: 0 REQ check(qr/conflicting definition of cseq/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 10 INVITE Cseq: 20 INVITE Content-length: 0 REQ check(qr/conflicting definition of call-id/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 20 INVITE Call-Id: barfoot@example.com Content-length: 0 REQ check(qr/conflicting definition of content-length/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 20 INVITE Content-length: 0 Content-length: 10 REQ check(qr/conflicting definition of from/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 20 INVITE Content-length: 0 From: REQ check(qr/conflicting definition of to/, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 20 INVITE Content-length: 0 To: REQ check(undef, <<'REQ'); INVITE sip:foo@bar.com SIP/2.0 From: To: Call-Id: foobar@example.com Cseq: 20 INVITE Content-length: 0 Contact: Contact: REQ done_testing(); sub check { my ($expect_err,$string) = @_; my $pkt = eval { Net::SIP::Packet->new($string) }; # diag($@ ? "error: $@": "no error"); if (! $expect_err) { ok($pkt,'valid message'); } else { like($@, $expect_err, "expected error: $expect_err"); } # diag($pkt->as_string) if $pkt; } Net-SIP-0.822/t/03_forward_stateless.t0000644000175100017510000000742313013325717016131 0ustar workworkuse strict; use warnings; use Net::SIP; use Test::More tests => 6; ################################################################ # test delivery of packets through stateless proxy # works by defining domain2leg to specify leg for domain(s). # the 'deliver' method of the legs are redefined so that no # actual delivery gets done but that delivery only gets simulated. # TODO: # - check with requests which have route header # - check with responses (routing based on via header) # - check that route and via header gets stripped and contact # header rewritten # - check strict routes vs. loose routers (manipulate URI # and route header to simulate behavior) # - more tests for Net::SIP::Dispatcher::resolve_uri (not # only related to stateless proxy) ################################################################ my %leg_setup = ( addr => '127.0.0.1', port => 0 ); my $leg_default = myLeg->new( outgoing_proxy => '10.0.3.4:28', %leg_setup ) || die; my $leg_example_com = myLeg->new( outgoing_proxy => '10.0.3.9:28', %leg_setup ) || die; my $leg_example_org = myLeg->new( outgoing_proxy => '10.0.3.12:28', %leg_setup ) || die; my $loop = Net::SIP::Dispatcher::Eventloop->new; my $disp = Net::SIP::Dispatcher->new( [ $leg_default, $leg_example_com, $leg_example_org ], $loop, domain2proxy => { 'example.com' => $leg_example_com->{outgoing_proxy}, 'example.org' => $leg_example_org->{outgoing_proxy}, '*.example.org' => $leg_example_org->{outgoing_proxy}, '*' => $leg_default->{outgoing_proxy}, }, ) || die; our $delivered_via; my $proxy = Net::SIP::StatelessProxy->new( dispatcher => $disp ); $disp->set_receiver( $proxy ); # ------------------------------------------------------------------------- # fw( address, incoming_leg, expected_outgoing_leg ) # ------------------------------------------------------------------------- fw( 'sip:me@example.com', $leg_default, $leg_example_com ); fw( 'sip:me@example.com', $leg_example_org, $leg_example_com ); fw( 'sip:me@somewhere.example.com', $leg_example_org, $leg_default ); fw( 'sip:me@example.org', $leg_example_com, $leg_example_org ); fw( 'sip:me@somewhere.example.org', $leg_example_com, $leg_example_org ); fw( 'sip:me@whatever', $leg_example_com, $leg_default ); # DONE # ------------------------------------------------------------------------- sub fw { my ($to,$incoming_leg,$expected_outgoing_leg) = @_; $delivered_via = undef; my $request = Net::SIP::Request->new( 'INVITE', $to, { to => $to, cseq => '1 INVITE', 'call-id' => sprintf( "%8x\@somewhere.com", rand(2**16 )), from => 'me@somewhere.com', }); $disp->receive( $request,$incoming_leg,'127.0.0.1:282' ); $loop->loop(1,\$delivered_via ); #diag("delivered_via=$delivered_via - expected = $expected_outgoing_leg"); ok( $delivered_via == $expected_outgoing_leg, 'expected leg' ); } # ------------------------------------------------------------------------- package myLeg; use base 'Net::SIP::Leg'; use Net::SIP::Debug; use Net::SIP::Util 'invoke_callback'; use fields qw( outgoing_proxy ); sub new { my ($class,%args) = @_; my $p = delete $args{outgoing_proxy}; my $self = $class->SUPER::new(%args); $self->{outgoing_proxy} = $p; return $self; } sub can_deliver_to { my $self = shift; my ($proto,$addr,$port) = do { if ( @_>1 ) { my %args = @_; @args{ qw/proto addr port/ } } else { sip_uri2sockinfo($_[0]) } }; return 1 if ! $addr || ! $port; return 1 if "$addr:$port" eq $self->{outgoing_proxy}; return 0; } sub deliver { my ($self,$packet,$addr,$callback) = @_; $::delivered_via = $self; DEBUG( "deliver through $self" ); invoke_callback( $callback,0 ); } Net-SIP-0.822/t/testlib.pl0000644000175100017510000002303013244175143013704 0ustar workworkuse strict; use warnings; use IO::Socket; use Net::SIP::Util qw(CAN_IPV6 INETSOCK ip_parts2string); #Net::SIP::Debug->level(100); $SIG{PIPE} = 'IGNORE'; ############################################################################ # # small test lib for common tasks: # ############################################################################ # small implementations if not used from Test::More (09_fdleak.t) if ( ! defined &ok ) { no strict 'refs'; *{'ok'} = sub { my ($bool,$desc) = @_; print $bool ? "ok ":"not ok ", '# ',$desc || '',"\n"; }; *{'diag'} = sub { print "# @_\n"; }; *{'note'} = sub { print "# @_\n"; }; *{'like'} = sub { my ( $data,$rx,$desc ) = @_; ok( $data =~ $rx ? 1:0, $desc ); }; } $SIG{ __DIE__ } = sub { ok( 0,"@_" ); killall(); exit(1); }; ############################################################################ # setup config for IPv6, TLS... ############################################################################ my $LEG_ARGS_SUB = sub {}; my $DEFAULT_LADDR = '127.0.0.1'; my $TRANSPORT = 'udp'; my $NO_TLS; sub test_use_config { my ($family,$transport) = @_; if ($family =~m{6}) { return "no support for IPv6" if ! CAN_IPV6 or ! INETSOCK(LocalAddr => '::1', Proto => 'udp'); $DEFAULT_LADDR = '::1'; } else { $DEFAULT_LADDR = '127.0.0.1'; } $TRANSPORT = $transport if $transport; if ($transport eq 'tls') { $NO_TLS //= eval { local $SIG{__DIE__} = undef; eval "use IO::Socket::SSL;1" || die "failed to load IO::Socket::SSL"; IO::Socket::SSL->VERSION >= 1.956 or die "need at least version 1.956"; 1; } ? '' : $@; $NO_TLS && return "no support for $transport: $NO_TLS"; my ($certdir) = grep { -f "$_/ca.pem" } qw(certs/ t/certs/) or die "cannot find certificates"; $LEG_ARGS_SUB = sub { my $who = shift; my $cert = "$certdir/$who.pem"; -f $cert or die "no cert for $who"; return ( tls => { SSL_cert_file => $cert, SSL_key_file => $cert, SSL_ca_file => "$certdir/ca.pem", # don't validate hostname SSL_verifycn_scheme => 'none', } ); }; } return; } sub test_leg_args { goto &$LEG_ARGS_SUB } sub test_sip_uri { my ($addr,$param) = @_; $param ||= {}; $param->{transport} = 'tcp' if $TRANSPORT eq 'tcp'; my $user = $addr =~s{^(.*)\@}{} ? $1 : undef; return sip_parts2uri($addr,$user, $TRANSPORT eq 'tls' ? 'sips' : 'sip', $param, ); } sub use_ipv6 { test_use_config('', shift() ? 'ip6' : 'ip4') } ############################################################################ # kill all process collected by fork_sub # Args: ?$signal # $signal: signal to use, default 9 # Returns: NONE ############################################################################ my @pids; sub killall { my $sig = shift || 9; kill $sig, @pids; #note( "killed @pids with $sig" ); while (1) { # collect all wait() >= 0 and next; $!{EINTR} and next; last; } @pids = (); } ############################################################################ # fork named sub with args and provide fd into subs STDOUT # Args: ($name,@args) # $name: name or ref to sub, if name it will be used for debugging # @args: arguments for sub # Returns: $fh # $fh: file handle to read STDOUT of sub ############################################################################ my %fd2name; # associated sub-name for file descriptor to subs STDOUT sub fork_sub { my ($name,@arg) = @_; my $sub = ref($name) ? $name : UNIVERSAL::can( 'main',$name ) || die; pipe( my $rh, my $wh ) || die $!; defined( my $pid = fork() ) || die $!; if ( ! $pid ) { # CHILD, exec sub $SIG{ __DIE__ } = undef; close($rh); open( STDOUT,'>&'.fileno($wh) ) || die $!; close( $wh ); STDOUT->autoflush; print "OK\n"; Debug->set_prefix( "DEBUG($name):" ); $sub->(@arg); exit(0); } push @pids,$pid; close( $wh ); $fd2name{$rh} = $name; fd_grep_ok( 'OK',10,$rh ) || die 'startup failed'; return $rh; } ############################################################################ # grep within fd's for specified regex or substring # Args: ($pattern,[ $timeout ],@fd) # $pattern: regex or substring # $timeout: how many seconds to wait for pattern, default 10 # @fd: which fds to search, usually fds from fork_sub(..) # Returns: $rv| ($rv,$name) # $rv: matched text if pattern is found, else undef # $name: name for file handle ############################################################################ my %fd2buf; # already read data from fd sub fd_grep { my $pattern = shift; my $timeout = 10; $timeout = shift if !ref($_[0]); my @fd = @_; $pattern = qr{\Q$pattern} if ! UNIVERSAL::isa( $pattern,'Regexp' ); my $name = join( "|", map { $fd2name{$_} || "$_" } @fd ); #note( "look for $pattern in $name" ); my @bad = wantarray ? ( undef,$name ):(undef); @fd || return @bad; my $rin = ''; map { $_->blocking(0); vec( $rin,fileno($_),1 ) = 1 } @fd; my $end = defined( $timeout ) ? time() + $timeout : undef; while (@fd) { # check existing buf from previous reads foreach my $fd (@fd) { my $buf = \$fd2buf{$fd}; $$buf || next; if ( $$buf =~s{\A(?:.*?)($pattern)(.*)}{$2}s ) { #note( "found" ); return wantarray ? ( $1,$name ) : $1; } } # if not found try to read new data $timeout = $end - time() if $end; return @bad if $timeout <= 0; my $n = select( my $rout = $rin,undef,undef,$timeout ); $rout || return @bad; # not found foreach my $fd (@fd) { my $name = $fd2name{$fd} || "$fd"; my $buf = \$fd2buf{$fd}; my $fn = fileno($fd); my $n; if ( defined ($fn)) { vec( $rout,$fn,1 ) || next; my $l = $$buf && length($$buf) || 0; $n = sysread( $fd,$$buf,8192,$l ); } if ( ! $n ) { #note( "$name >CLOSED<" ); delete $fd2buf{$fd}; @fd = grep { $_ != $fd } @fd; close($fd); next; } note( "$name >> ".substr( $$buf,-$n ). "<<" ); } } return @bad; } ############################################################################ # like Test::Simple::ok, but based on fd_grep, same as # ok( fd_grep( pattern,... ), "[$subname] $pattern" ) # Args: ($pattern,[ $timeout ],@fd) - see fd_grep # Returns: $rv - like in fd_grep # Comment: if !$rv and wantarray says void it will die() ############################################################################ sub fd_grep_ok { my $pattern = shift; my ($rv,$name) = fd_grep( $pattern, @_ ); local $Test::Builder::Level = $Test::Builder::Level || 0 +1; ok( $rv,"[$name] $pattern" ); die "fatal error" if !$rv && ! defined wantarray; return $rv; } ############################################################################ # dump media information on SIP packet to STDOUT # Args: (@prefix,$packet,$from) # Returns: NONE ############################################################################ sub sip_dump_media { my $from = pop; my $packet = pop; my $dump = @_ ? "@_ ":''; $dump .= "$from "; if ( $packet->is_request ) { $dump .= sprintf "REQ(%s) ",$packet->method; } else { $dump .= sprintf "RSP(%s,%s) ",$packet->method,$packet->code; } if ( my $sdp = $packet->sdp_body ) { $dump .= "SDP:"; foreach my $m ( $sdp->get_media ) { $dump .= sprintf(" %s=%s/%d", $m->{media}, ip_parts2string($m->{addr},$m->{port}), $m->{range}); } } else { $dump .= "NO SDP"; } print $dump."\n"; } ############################################################################ # create isocket on IP # return socket and ip:port ############################################################################ sub create_socket { my ($proto,$addr,$port) = @_; $addr ||= $DEFAULT_LADDR; $proto ||= 'udp'; $proto = 'tcp' if $proto eq 'tls'; $port ||= 0; my $sock = INETSOCK( Proto => $proto, $proto eq 'tcp' ? ( Listen => 10 ):(), LocalAddr => $addr, LocalPort => $port, ) || die $!; return $sock if ! wantarray; return ($sock, ip_parts2string($sock->sockhost,$sock->sockport,$sock->sockdomain)); } ############################################################################ # redefined Leg for Tests: # - can have explicit destination # - can intercept receive and deliver for printing out packets ############################################################################ package TestLeg; use base 'Net::SIP::Leg'; use fields qw( can_deliver_to dump_incoming dump_outgoing ); use Net::SIP::Util ':all'; sub new { my ($class,%args) = @_; my @lfields = qw( can_deliver_to dump_incoming dump_outgoing ); my %largs = map { $_ => delete $args{$_} } @lfields; my $self = $class->SUPER::new( %args ); if ( my $ct = delete $largs{can_deliver_to} ) { $self->{can_deliver_to} = _parse_addr($ct); } %$self = ( %$self, %largs ); return $self; } sub can_deliver_to { my $self = shift; my $spec = @_ == 1 ? _parse_addr( $_[0] ) : { @_ }; my $ct = $self->{can_deliver_to}; if ( $ct ) { foreach (qw( addr proto port )) { next if ! $spec->{$_} || ! $ct->{$_}; return if $spec->{$_} ne $ct->{$_}; } } return $self->SUPER::can_deliver_to( @_ ); } sub _parse_addr { my %rv; @rv{ qw(proto host port family) } = sip_uri2sockinfo(shift()); return \%rv; } sub receive { my $self = shift; my @rv = $self->SUPER::receive(@_) or return; invoke_callback( $self->{dump_incoming},@rv ); return @rv; } sub deliver { my ($self,$packet,$to,$callback) = @_; invoke_callback($self->{dump_outgoing}, $packet, ip_parts2string($to)); return $self->SUPER::deliver( $packet,$to,$callback ); } 1; Net-SIP-0.822/t/01_load.t0000644000175100017510000000055712271423305013311 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; eval <<'EVAL'; use Net::SIP; use Net::SIP::NATHelper::Base; use Net::SIP::NATHelper::Client; use Net::SIP::NATHelper::Server; use Net::SIP::NATHelper::Local; use Net::SIP::Dropper; use Net::SIP::Dropper::ByIPPort; use Net::SIP::Dropper::ByField; EVAL cmp_ok( $@,'eq','', 'loading Net::SIP*' ); Net-SIP-0.822/t/22_stateless_proxy_ack_on_error.t0000644000175100017510000001272413371561005020371 0ustar workwork#!/usr/bin/perl # make sure that ACK to error response gets passed through proxy use strict; use warnings; use Test::More; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Net::SIP::NATHelper::Local; use Net::SIP::NATHelper::Server; use Net::SIP::NATHelper::Client; use Net::SIP::Blocker; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { for my $nat ('no-nat', 'inline-nat', 'remote-nat') { push @tests, [ $transport, $family, $nat ]; } } } #@tests = ['udp','ip4','no-nat']; my $testsize = 19; plan tests => $testsize*@tests; for my $t (@tests) { my ($transport,$family,$nat) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,$testsize; next; } note("------- test with family $family transport $transport $nat"); do_test($transport,$nat) } } killall(); sub do_test { my ($transport,$natspec) = @_; my ($luac,$luas,@lproxy); for ( [ 'caller.sip.test', \$luac ], [ 'listen.sip.test', \$luas ], [ 'proxy.sip.test', \$lproxy[0] ], [ 'proxy.sip.test', \$lproxy[1] ], ) { my ($name,$config) = @$_; my ($sock,$addr) = create_socket($transport); $$config = { name => $name, sock => $sock, addr => $addr, uri => test_sip_uri($addr), }; } note( "UAS on $luas->{addr} " ); note( "UAC on $luac->{addr} " ); note( "PROXY on $lproxy[0]{addr} $lproxy[1]{addr} " ); # restrict legs of proxy so that packets gets routed even # if all is on the same interface. Enable dumping on # incoing and outgoing packets to check NAT for ( $luac,$luas,$lproxy[0],$lproxy[1] ) { $_->{leg} = TestLeg->new( sock => $_->{sock}, dump_incoming => [ \&sip_dump_media,'I<' ], dump_outgoing => [ \&sip_dump_media,'O>' ], $_ == $lproxy[0] ? ( can_deliver_to => $luac->{addr} ) :(), $_ == $lproxy[1] ? ( can_deliver_to => $luas->{addr} ) :(), test_leg_args($_->{name}), ); } # socket for nathelper server my ($nath_sock,$nath_addr) = create_socket('tcp') or die $!; my $natcb; if ( $natspec eq 'inline-nat' ) { $natcb = sub { NATHelper_Local->new( shift ) }; ok(1,'no fork nathelper'); } elsif ( $natspec eq 'remote-nat' ) { fork_sub( 'nathelper',$nath_sock ); $natcb = sub { NATHelper_Client->new( $nath_addr ) } } else { ok(1,'no fork nathelper'); } # start proxy and UAS and wait until they are ready my $proxy = fork_sub( 'proxy', @lproxy,$luas->{uri},$natcb ); my $uas = fork_sub( 'uas', $luas ); fd_grep_ok( 'ready',10,$proxy ) || die; fd_grep_ok( 'ready',10,$uas ) || die; # UAC: invite my $uac = fork_sub( 'uac', $luac, $lproxy[0]{uri} ); fd_grep_ok( 'ready',10,$uac ) || die; fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},5,$uac ) || die; fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},5,$proxy ) || die; fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},1,$proxy ) || die; fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},1,$uas ) || die; # UAS: reject with error 404 - propagate to uac via proxy fd_grep_ok( qr{O>.*RSP\(INVITE,404\)},5,$uas) || die; fd_grep_ok( qr{I<.*RSP\(INVITE,404\)},5,$proxy) || die; fd_grep_ok( qr{O>.*RSP\(INVITE,404\)},1,$proxy) || die; fd_grep_ok( qr{I<.*RSP\(INVITE,404\)},1,$uac) || die; # UAC: reply with ACK to error - propagate to uas via proxy fd_grep_ok( qr{O>.*REQ\(ACK\)},5,$uac ) || die; fd_grep_ok( qr{I<.*REQ\(ACK\)},5,$proxy ) || die; fd_grep_ok( qr{O>.*REQ\(ACK\)},1,$proxy ) || die; fd_grep_ok( qr{I<.*REQ\(ACK\)},1,$uas ) || die; killall(); } killall(); ############################################################################# # Proxy ############################################################################# sub proxy { my ($lsock_c,$lsock_s,$proxy_uri,$natcb) = @_; # need loop separately my $loop = Dispatcher_Eventloop->new; my $nathelper = invoke_callback( $natcb,$loop ); # create Net::SIP::Simple object my $proxy = Simple->new( loop => $loop, legs => [ $lsock_c->{leg}, $lsock_s->{leg} ], domain2proxy => { 'example.com' => $proxy_uri }, ); $proxy->create_stateless_proxy( nathelper => $nathelper ); print "ready\n"; $proxy->loop; } ############################################################################# # UAC ############################################################################# sub uac { my ($leg,$proxy_uri) = @_; my $ua = Simple->new( from => '', leg => $leg->{leg}, outgoing_proxy => $proxy_uri, ); print "ready\n"; my $done; my $call = $ua->invite('', cb_final => \$done, ) or die; $ua->loop(10,\$done); $ua->cleanup; } ############################################################################# # UAS ############################################################################# sub uas { my ($leg) = @_; print "UAS created\n"; my $ua = Simple->new( from => '', leg => $leg->{leg}, ); print "ready\n"; $ua->listen( cb_invite => sub { my ($self,$request) = @_; return $request->create_response('404','unknown',{}); } ); $ua->loop(10); } # -------------------------------------------------------------- # NATHelper::Server # -------------------------------------------------------------- sub nathelper { my $sock = shift; NATHelper_Server->new( $sock )->loop; } Net-SIP-0.822/t/05_call_with_stateless_proxy.t0000644000175100017510000001667513310770243017705 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC, a UAS and a stateless proxy using Net::SIP::Simple # makes call from UAC to UAS via proxy # transfers RTP data during call, then hangs up # tests will be done without NAT, with inline NAT and with external nathelper ########################################################################### use strict; use warnings; use Test::More tests => 63*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Net::SIP::NATHelper::Local; use Net::SIP::NATHelper::Server; use Net::SIP::NATHelper::Client; use IO::Socket; use File::Temp; use List::Util; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,63; next; } note("------- test with family $family transport $transport"); do_test($transport) } } killall(); sub do_test { my $transport = shift; my ($luac,$luas,@lproxy); for ( [ 'caller.sip.test', \$luac ], [ 'listen.sip.test', \$luas ], [ 'proxy.sip.test', \$lproxy[0] ], [ 'proxy.sip.test', \$lproxy[1] ], ) { my ($name,$config) = @$_; my ($sock,$addr) = create_socket($transport); $$config = { name => $name, sock => $sock, addr => $addr, uri => test_sip_uri($addr), }; } note( "UAS on $luas->{addr} " ); note( "UAC on $luac->{addr} " ); note( "PROXY on $lproxy[0]{addr} $lproxy[1]{addr} " ); # restrict legs of proxy so that packets gets routed even # if all is on the same interface. Enable dumping on # incoing and outgoing packets to check NAT for ( $luac,$luas,$lproxy[0],$lproxy[1] ) { $_->{leg} = TestLeg->new( sock => $_->{sock}, dump_incoming => [ \&sip_dump_media,'I<' ], dump_outgoing => [ \&sip_dump_media,'O>' ], $_ == $lproxy[0] ? ( can_deliver_to => $luac->{addr} ) :(), $_ == $lproxy[1] ? ( can_deliver_to => $luas->{addr} ) :(), test_leg_args($_->{name}), ); } # socket for nathelper server my ($nath_sock,$nath_addr) = create_socket('tcp') or die $!; foreach my $spec ( qw( no-nat inline-nat remote-nat )) { my $natcb; if ( $spec eq 'inline-nat' ) { $natcb = sub { NATHelper_Local->new( shift ) }; } elsif ( $spec eq 'remote-nat' ) { fork_sub( 'nathelper',$nath_sock ); $natcb = sub { NATHelper_Client->new( $nath_addr ) } } # start proxy and UAS and wait until they are ready my $proxy = fork_sub( 'proxy', @lproxy,$luas->{uri},$natcb ); my $uas = fork_sub( 'uas', $luas ); fd_grep_ok( 'ready',10,$proxy ) || die; fd_grep_ok( 'ready',10,$uas ) || die; # UAC: invite and transfer RTP data my $uac = fork_sub( 'uac', $luac, $lproxy[0]{uri} ); fd_grep_ok( 'ready',10,$uac ) || die; my $uac_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},5,$uac ) || die; my $pin_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},5,$proxy ) || die; my $pout_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},1,$proxy ) || die; my $uas_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},1,$uas ) || die; s{.*audio=}{} for ( $uac_invite,$pin_invite,$pout_invite,$uas_invite ); # check for NAT ok( $uac_invite eq $pin_invite, "outgoing on UAC must be the same as incoming on proxy" ); ok( $pout_invite eq $uas_invite, "outgoing on proxy must be the same as incoming on UAS" ); if ( $spec eq 'no-nat' ) { ok( $uac_invite eq $uas_invite, "SDP must pass unchanged to UAS" ); } else { # get port/range and compare my ($sock_i,$range_i) = split( m{/},$pin_invite,2 ); my ($sock_o,$range_o) = split( m{/},$pout_invite,2 ); ok( $sock_i ne $sock_o, "allocated addr:port must be different ($sock_i|$sock_o)" ); ok( $range_i == $range_o, "ranges must stay the same" ); } # top via must be from lproxy[1], next via from UAC # this is to show that the request went through the proxy fd_grep_ok( 'call created',10,$uas ); fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $lproxy[1]{addr};}i,1,$uas ); fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $luac->{addr};}i,1,$uas ); # done fd_grep_ok( 'RTP done',10,$uac ); fd_grep_ok( 'RTP ok',10,$uas ); fd_grep_ok( 'END',10,$uac ); fd_grep_ok( 'END',10,$uas ); killall(); } } # -------------------------------------------------------------- # Proxy # -------------------------------------------------------------- sub proxy { my ($lsock_c,$lsock_s,$proxy_uri,$natcb) = @_; # need loop separately my $loop = Dispatcher_Eventloop->new; my $nathelper = invoke_callback( $natcb,$loop ); # create Net::SIP::Simple object my $proxy = Simple->new( loop => $loop, legs => [ $lsock_c->{leg}, $lsock_s->{leg} ], domain2proxy => { 'example.com' => $proxy_uri }, ); $proxy->create_stateless_proxy( nathelper => $nathelper ); print "ready\n"; $proxy->loop; } # -------------------------------------------------------------- # UAC # -------------------------------------------------------------- sub uac { my ($lsock,$proxy_uri) = @_; my $packets = 100; my $send_something = sub { return unless $packets-- > 0; my $buf = sprintf "%010d",$packets; $buf .= "1234567890" x 15; return $buf; # 160 bytes for PCMU/8000 }; # create Net::SIP::Simple object my $uac = Simple->new( from => 'me.uac@example.com', leg => $lsock->{leg}, outgoing_proxy => $proxy_uri, ) || die; print "ready\n"; # Call UAS vi proxy my $rtp_done; my $call = $uac->invite( 'you.uas@example.com', init_media => $uac->rtp( 'send_recv', $send_something ), cb_rtp_done => \$rtp_done, ); print "call established\n" if $call && ! $uac->error; $call->loop( \$rtp_done, 10 ); print "RTP done\n" if $rtp_done; my $stop; $call->bye( cb_final => \$stop ); $call->loop( \$stop,10 ); $uac->cleanup; print "END\n"; } # -------------------------------------------------------------- # UAS # -------------------------------------------------------------- sub uas { my ($leg) = @_; my $uas = Simple->new( domain => 'example.com', leg => $leg->{leg} ) || die $!; # store received RTP data in array my @received; my $save_rtp = sub { my $buf = shift; push @received,$buf; #warn substr( $buf,0,10)."\n"; }; # Listen my $call_closed; my $cb_create = sub { my ($call,$request) = @_; print "call created\n"; print $request->as_string; 1; }; $uas->listen( cb_create => $cb_create, cb_established => sub { print "call established\n" }, cb_cleanup => sub { print "call cleaned up\n"; $call_closed =1; }, init_media => $uas->rtp( 'recv_echo', $save_rtp ), ); print "ready\n"; # Loop until call is closed, at most 10 seconds $uas->loop( \$call_closed, 10 ); $uas->cleanup; print "received ".int(@received)."/100 packets\n"; # at least 20% of all RTP packets should come through if ( @received > 20 ) { print "RTP ok\n" } else { print "RTP received only ".int(@received)."/100 packets\n"; } # done if ( $call_closed ) { print "END\n"; } else { print "call closed by timeout not stopvar\n"; } } # -------------------------------------------------------------- # NATHelper::Server # -------------------------------------------------------------- sub nathelper { my $sock = shift; NATHelper_Server->new( $sock )->loop; } Net-SIP-0.822/t/18_register_with_auth_step_by_step.t0000644000175100017510000001110113022210602021032 0ustar workwork#!/usr/bin/perl ############################################################################# # test Authorize in front of Registrar inside a ReceiveChain # to authorize REGISTER requests ############################################################################# use strict; use warnings; use Test::More tests => 8*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Digest::MD5 'md5_hex'; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,8; next; } note("------- test with family $family transport $transport"); my ($csock,$caddr) = create_socket($transport); my ($ssock,$saddr) = create_socket($transport); # start Registrar my $registrar = fork_sub( 'registrar',$ssock,$saddr ); fd_grep_ok( 'Listening',$registrar ); # start UAC once Registrar is ready my $uac = fork_sub( 'uac',$csock,$caddr,$saddr ); fd_grep_ok( 'Started',$uac ); fd_grep_ok( 'got 401 response',$uac ); fd_grep_ok( 'Registered wolf (REALM.example.com)',$uac ); fd_grep_ok( 'Registered 007 (REALM.example.com)',$uac ); fd_grep_ok( 'Registered noauth ()',$uac ); } } killall(); ############################################################################# # UAC # Try to register me@example.com with auth wolf:lobo and 007:secret. # In both cases authorization should be required. # Then register noauth@example.com in which case no authorization should # be required (see sub registrar) # auth is done with callback so that we see if the authorization was required ############################################################################# sub uac { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( from => test_sip_uri('me@example.com'), leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ) ); print "Started\n"; # first registration w/o auth my $resp40x; $ua->register( registrar => test_sip_uri($peer), cb_final => sub { my ($what,%args) = @_; die if $what ne 'FAIL'; $resp40x = $args{packet} or die; }, ); $ua->loop(\$resp40x); print "got ".$resp40x->code." response\n"; # then issue another registration based on auth response from # last failed registration my $realm = ''; $ua->register( registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ 'wolf','lobo' ], }, resp40x => $resp40x, ) || die; print "Registered wolf ($realm)\n"; $realm = ''; $ua->register( registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; print "Registered 007 ($realm)\n"; $realm = ''; $ua->register( from => test_sip_uri('noauth@example.com'), registrar => test_sip_uri($peer), auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; $ua->cleanup; print "Registered noauth ($realm)\n"; } ############################################################################# # Registrar with Authorize in front # The $auth_chain consists of an ReceiveChain with a Authorize object # inside. The ReceiveChain has a filter so that only requests with # contact info !~ noauth\@ will be forwarded to the Authorize object # Then $auth_chain is put in front of the Registrar object into a chain # which then handles all packets # The result is, that all requests must be authorized, except the ones # where contact matches noauth\@ ############################################################################# sub registrar { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('proxy.sip.test'), ) ); my $auth = Authorize->new( dispatcher => $ua->{dispatcher}, user2a1 => { '007' => md5_hex('007:REALM.example.com:secret') }, user2pass => sub { $_[0] eq 'wolf' ? 'lobo' : 'no-useful-password' }, realm => 'REALM.example.com', opaque => 'HumptyDumpty', i_am_proxy => 0, ); my $auth_chain = ReceiveChain->new( [ $auth ], filter => sub { my ($packet,$leg,$from) = @_; # no auth for responses and noauth@... return if $packet->is_response; my $need_auth = $packet->get_header( 'contact' ) !~m{noauth\@}; return $need_auth; } ); my $reg = Registrar->new( dispatcher => $ua->{dispatcher}, domain => 'example.com', ); $ua->create_chain( [ $auth_chain,$reg ] ); print "Listening\n"; $ua->loop } Net-SIP-0.822/t/02_listen_and_invite.t0000644000175100017510000000726513022210172016063 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # Call does not involve transfer of RTP data ########################################################################### use strict; use warnings; use Test::More tests => 10*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP; use Net::SIP::Util ':all'; use IO::Socket; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ipv6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,10; next; } note("------- test with family $family transport $transport"); # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket($transport); ok( $sock_uas, 'create UAS socket' ); # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # to sync UAC with UAS my $pid = fork(); if ( defined($pid) && $pid == 0 ) { $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } ok( $pid, "fork successful" ); close( $sock_uas ); close($write); alarm(15); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac(test_sip_uri($uas_addr), $read); ok( <$read>, "UAS finished" ); wait; } } ############################################### # UAC ############################################### sub uac { my ($peer_uri, $pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my ($transport) = sip_uri2sockinfo($peer_uri); my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', domain2proxy => { 'example.com' => $peer_uri }, leg => Net::SIP::Leg->new( sock => (create_socket($transport))[0], test_leg_args('caller.sip.test'), ) ); ok( $uac, 'UAC created' ); ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready my $ringing = 0; my $call = $uac->invite( 'you.uas@example.com', cb_preliminary => sub { my ($self,$code,$packet) = @_; if ( $code == 180 ) { diag( 'got ringing' ); $ringing ++ } } ); ok( $ringing,'got ringing' ); ok( ! $uac->error, 'no error on UAC' ); ok( $call, 'Call established' ); $call->loop(1); my $stop; $call->bye( cb_final => \$stop ); $call->loop( \$stop,10 ); ok( $stop, 'UAS down' ); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => Net::SIP::Leg->new( sock => $sock, test_leg_args('listen.sip.test'), ) ) || die $!; print $pipe "UAS created\n"; # Listen my $call_closed; $uas->listen( cb_create => sub { my ($call,$request,$leg,$from) = @_; diag( 'call created' ); my $response = $request->create_response( '180','Ringing' ); $call->{endpoint}->new_response( $call->{ctx},$response,$leg,$from ); 1; }, cb_established => sub { diag( 'call established' ) }, cb_cleanup => sub { diag( 'call cleaned up' ); $call_closed =1; }, ); # notify UAC process that I'm listening print $pipe "UAS ready\n"; # Loop until call is closed, at most 10 seconds $uas->loop( \$call_closed, 10 ); $uas->cleanup; # done if ( $call_closed ) { print $pipe "UAS finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } } Net-SIP-0.822/t/04_call_with_rtp.t0000644000175100017510000001050413211213124015210 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # transfer RTP data during call, then hang up ########################################################################### use strict; use warnings; use Test::More tests => 8*6; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use IO::Socket; use File::Temp; my @tests; for my $transport (qw(udp tcp tls)) { for my $family (qw(ip4 ip6)) { push @tests, [ $transport, $family ]; } } for my $t (@tests) { my ($transport,$family) = @$t; SKIP: { if (my $err = test_use_config($family,$transport)) { skip $err,8; next; } note("------- test with family $family transport $transport"); do_test($transport); } } sub do_test { my $transport = shift; # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket($transport); note( "UAS on $uas_addr" ); # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # for status updates defined( my $pid = fork() ) || die $!; if ( $pid == 0 ) { # CHILD = UAS $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } local $SIG{__DIE__} = sub { kill 9,$pid if $pid; ok( 0,'died' ) }; local $SIG{ALRM} = sub { kill 9,$pid if $pid; ok( 0,'timed out' ) }; alarm(30); # PARENT = UAC close( $sock_uas ); close($write); uac(test_sip_uri($uas_addr), $read); ok( <$read>, "UAS finished" ); killall(); } ############################################### # UAC ############################################### sub uac { my ($peer_uri,$pipe) = @_; Debug->set_prefix( "DEBUG(uac):" ); my $packets = 100; my $send_something = sub { return unless $packets-- > 0; my $buf = sprintf "%010d",$packets; $buf .= "1234567890" x 15; return $buf; # 160 bytes for PCMU/8000 }; # create Net::SIP::Simple object my $rtp_done; my ($transport) = sip_uri2sockinfo($peer_uri); my ($lsock,$laddr) = create_socket($transport); note( "UAC on $laddr" ); my $uac = Simple->new( from => 'me.uac@example.com', domain2proxy => { 'example.com' => $peer_uri }, leg => Net::SIP::Leg->new( sock => $lsock, test_leg_args('caller.sip.test'), ), ); ok( $uac, 'UAC created' ); # wait until UAS is ready and listening ok( <$pipe>, "UAS ready\n" ); # Call UAS my $call = $uac->invite( 'you.uas@example.com', init_media => $uac->rtp( 'send_recv', $send_something ), cb_rtp_done => \$rtp_done, ); ok( ! $uac->error, 'no error on UAC' ); ok( $call, 'Call established' ); $call->loop( \$rtp_done, 10 ); ok( $rtp_done, "Done sending RTP" ); my $stop; $call->bye( cb_final => \$stop ); $call->loop( \$stop,10 ); ok( $stop, 'UAS down' ); ok( <$pipe>, "UAS RTP ok\n" ); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $uas = Simple->new( domain => 'example.com', leg => Net::SIP::Leg->new( sock => $sock, test_leg_args('listen.sip.test'), ), ) || die $!; # store received RTP data in array my @received; my $save_rtp = sub { my $buf = shift; push @received,$buf; #warn substr( $buf,0,10)."\n"; }; # Listen my $call_closed; $uas->listen( cb_create => sub { note( 'call created' );1 }, cb_established => sub { note( 'call established' ) }, cb_cleanup => sub { note( 'call cleaned up' ); $call_closed =1; }, init_media => $uas->rtp( 'recv_echo', $save_rtp ), ); # notify UAC process that I'm listening print $pipe "UAS ready\n"; # Loop until call is closed, at most 10 seconds $uas->loop( \$call_closed, 10 ); $uas->cleanup; note( "received ".int(@received)."/100 packets" ); # at least 20% of all RTP packets should come through if ( @received > 20 ) { print $pipe "UAS RTP ok\n" } else { print $pipe "UAS RTP received only ".int(@received)."/100 packets\n"; } # done if ( $call_closed ) { print $pipe "UAS finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } } Net-SIP-0.822/t/16_drop_invite.t0000644000175100017510000000735013016115241014713 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # this calls will be dropped by UAS ########################################################################### use strict; use warnings; use Test::More tests => 9; use Cwd; # Try to make sure we are in the test directory my $cwd = Cwd::cwd(); chdir 't' if $cwd !~ m{/t$}; $cwd = Cwd::cwd(); use IO::Socket; use Net::SIP ':alias'; use Net::SIP::Util ':all'; use Net::SIP::Blocker; use Net::SIP::Dropper; use Net::SIP::Dropper::ByIPPort; use Net::SIP::Dropper::ByField; use Net::SIP::ReceiveChain; # Open a filehandle to anonymous tempfile ok( open( my $tfh, "+>", undef ), "open tempfile"); # create leg for UAS on dynamic port my $sock_uas = IO::Socket::INET->new( Proto => 'udp', LocalAddr => '127.0.0.1', LocalPort => 0, # let system pick one ); ok( $sock_uas, 'create socket' ); # get address for UAS my ($port,$host) = unpack_sockaddr_in ( getsockname($sock_uas)); $host = inet_ntoa( $host ); # fork UAS and make call from UAC to UAS pipe( my $read,my $write); # to sync UAC with UAS my $pid = fork(); if ( defined($pid) && $pid == 0 ) { $SIG{__DIE__} = undef; close($read); $write->autoflush; uas( $sock_uas, $write, $host ); exit(0); } ok( $pid, "fork successful" ); close( $sock_uas ); close($write); alarm(10); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac( "$host:$port", $read ); ok( <$read>, "UAS got INVITE, dropped it and wrote database file" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer_addr,$pipe) = @_; Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created" ); # wait until UAS is ready my $uac = Simple->new( from => 'me.uac@example.com', leg => scalar(create_socket_to( $peer_addr )), domain2proxy => { 'example.com' => $peer_addr }, ); ok( $uac, 'UAC created' ); my $dropping; my $call = $uac->invite( 'you.uas@example.com', cb_final => sub { $dropping++ } ); ok( <$pipe>, "UAS ready" ); # wait until UAS is ready ok( ! $uac->error, "UAC ready\nNow send INVITE for 5 seconds" ); # print UAC address into tempfile print $tfh $uac->{dispatcher}{legs}[0]->laddr(1); close($tfh); $call->loop(\$dropping, 5); # done ok( ! $dropping,'UAC got no answer from UAS' ); $uac->cleanup; } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe,$uac_ip) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $leg = Leg->new( sock => $sock ); my $loop = Dispatcher_Eventloop->new; my $disp = Dispatcher->new( [ $leg ],$loop ) || die $!; print $pipe "UAS created\n"; # Dropping my $by_ipport = Net::SIP::Dropper::ByIPPort->new( database => "$cwd/database.drop", methods => [ 'INVITE' ], attempts => 10, interval => 60, ); my $by_field = Net::SIP::Dropper::ByField->new( 'From' => qr{uac.+xamp}, ); my $drop = Net::SIP::Dropper->new( cbs => [ $by_ipport,$by_field ]); # Block (= send answer) if not droped my $block = Net::SIP::Blocker->new( block => { 'INVITE' => 405 }, dispatcher => $disp, ); my $chain = Net::SIP::ReceiveChain->new( [ $drop, $block ] ); $disp->set_receiver( $chain ); print $pipe "UAS ready\n"; $loop->loop(2); seek( $tfh,0,0); my $line = <$tfh>; $line =~m{^127.0.0.1(?::(\d+))?$} or die "unexpected line $line"; my $uac_port = $1 || 5060; close($tfh); if ( $by_ipport->data->{$uac_ip}{$uac_port} ) { print $pipe "UAS got INVITE, dropped it and wrote database file\n"; } } Net-SIP-0.822/t/13_maddr_proxy.t0000644000175100017510000000326013016115054014714 0ustar workwork#!/usr/bin/perl ########################################################################### # creates a UAC and a UAS using Net::SIP::Simple # and makes call from UAC to UAS, # Call does not involve transfer of RTP data ########################################################################### use strict; use warnings; use Test::More tests => 1; use Net::SIP ':all'; my $leg = myLeg->new( sock => \*STDOUT, # just fake so that it does not create a new socket addr => '10.0.105.10', port => '5062', proto => 'udp', ); my $ua = Simple->new( legs => [ $leg ] ); $ua->create_stateless_proxy; my $packet = Net::SIP::Packet->new( <<'PKT' ); NOTIFY sip:john@10.0.100.189:5060 SIP/2.0 Via: SIP/2.0/UDP 10.0.105.10:5066;branch=z9hG4bK75852cbf.3a07466d.64f68271 Max-Forwards: 70 Route: Route: Contact: To: ;tag=nura947nd1hc6sd009bj From: ;tag=13cb22556957d43f-57b1b5d5.0 Call-ID: HuOAA9-5oIe1iM9neZbyp4fPeoAGdt CSeq: 929505408 NOTIFY Event: nexos Content-Type: application/vnd.ericsson.lmc.sipuaconfig+xml P-Asserted-Identity: Subscription-State: active;expires=3600 Content-Length: 0 PKT my $disp = $ua->{dispatcher}; $disp->receive( $packet, $leg, '127.0.0.1:1919' ); ########################################################################### package myLeg; use base 'Net::SIP::Leg'; use Test::More; sub sendto { my myLeg $self = shift; my ($packet,$dst,$callback) = @_; ok("$dst->{addr}:$dst->{port}" eq "172.25.2.1:7070", "got target from maddr"); } Net-SIP-0.822/HOWTO0000644000175100017510000000371311136273030012257 0ustar workwork1. How can I help ? At the moment the development is still full speed, so coding will be done mainly by myself. But new samples and tests are welcome. The best help at the moment is to test the stuff against as much as possible other SIP implementations as possible and report back failures and successes and of course bugs. 2. How can I integrate it with my own Mainloop (Tk, POE, Event::Lib...)? You need to implement the interface of Net::SIP::Dispatcher::Eventloop. See the documentation for it. An important issue is, that the builtin event loop is level triggered, e.g. callbacks on file descriptors gets called as long as there are data available. This is the way select(2) or poll(2) work. But Event::Lib for instance is edge triggert, e.g. a callback gets called only when *new* data ara available. So to integrate with an edge triggered event mechanism you have to compansate it, like using poll for getting the current level after you got a callback on an edge. The builtin event loop features ways to end the loop by using a timeout or references to scalars. You have to implement this part only if you want to use Net::SIP::Simple, the rest of the code does not depend on these features. 3. How can I use my own implementation of a leg and why would I want to do this? The leg is the point where packets come in and packets leave the application, so this is a good place to do debugging, filtering (like restricting the methods, the sources or the destinations), rewrites of packets etc. To have your own leg you can just subclass Net::SIP::Leg and define the appropriate methods (especially deliver and receive). To use your leg class with Net::SIP::Simple you have to explicitly create your own legs and tell Net::SIP::Simple to use it, there is currently no way to tell Net::SIP::Simple to use another leg class. See t/testlib.pl or bin/stateless_proxy.pl for examples. Net-SIP-0.822/TODO0000644000175100017510000000065713016115054012130 0ustar workwork = TODO later - forward keep-alive \r\n in TCP in stateless proxy. See RFC 5626 4.4.1 - support TLS - Redirect only specific domains, ignore rest so that it can be chained with proxy for the rest - document dns_host2ip and dns_domain2srv in Net::SIP::Dispatcher - do not look up tcp in Dispatcher::resolve_uri if we have no leg which can do tcp - more tests - more documentation * samples for integration with other loops Net-SIP-0.822/Changes0000644000175100017510000011032713552315072012736 0ustar workworkRevision history for Net::SIP 0.822 2019-10-18 - Fix of bug introduced in 0.821 while fixing NATHelper. Could lead to dereferencing an undefined value 0.821 2019-10-16 - fixes in NATHelper and StatelessProxy for early close of sessions, specifically incomplete sessions resulting from errors or authentication or from CANCEL - Resent request after authentication with same dst_addr and leg as given to the original request - https://github.com/noxxi/p5-net-sip/pull/21 Thanks to Richard Carver - explicitly include the algorithm in Auth response if it was given in the challenge - https://github.com/noxxi/p5-net-sip/pull/22 Thanks to Martin Falkus - Proper default for PeerPort in Leg::new https://rt.cpan.org/Public/Bug/Display.html?id=130471 Thanks to cj.fooser AT gmail.com 0.820 2019-02-14 - loose check from 0.819 - allow multiple contacts 0.819 2019-02-14 - Net::SIP::Packet - add more checks when parsing a packet from string, notably about conflicting fields like multiple cseq or conflic between method in cseq vs method in request. 0.818 2018-11-10 - fixed wrong skip size in t/22_stateless_proxy_ack_on_error.t in case specific features like IPv6 or TLS where not available 0.817 2018-11-07 - recreate test certificates so that they work with restrictions in openssl 1.1.1 0.816 2018-11-07 - StatelessProxy: make sure ACK to error passes through proxy if NAT is used - Simple::RTP: add payload type to write callback - Simple::RTP: don't die() if RTP send fails, just ignore the problem 0.815 2018-06-15 - StatelessProxy: make sure that idfrom/idto in NAT helper are based on normalized URL, so that different writing (with comment, with <..>..) do not affect the value. This is needed if peers use a different syntax for the same URI during the dialog. - use range of 2 for all RTP/ types, not only for RTP/AVP (i.e. also for RTP/SAVP, RTP/AVPF..) - fix/enhance documentation https://rt.cpan.org/Ticket/Display.html?id=125142 https://rt.cpan.org/Ticket/Display.html?id=125054 0.814 2018-02-24 - fix t/20_channel_on_hold.t of IPv6 or TLS are not supported (wrong number of skipped tests). - fix tests if no IPv6 is supported - StatlessProxy/NAT - sub callbacks: remove callbacks which have no destination due to the channel being inactive/sendonly 0.813 2018-02-21 - StatelessProxy - support for inactive or sendonly channels (port=0) in NAT scenario - only rewrite SDP inside INVITE|ACK request|response - properly handle parameters in contact argument: fixes https://github.com/noxxi/p5-net-sip/pull/14 0.812 2017-11-22 - don't include To-Header into computation of branch, since this might differ between INVITE and ACK (by adding the tag from the response). - RT#123685 - better debug-output in StatelessProxy on DNS problems - RT#122925 - call StatelessProxy::__forward_packet_final as method not function to allow overriding in special cases - this does not make it a public API! - RT#122595 - Net::SIP::Debug->level looks for useful caller now starting with caller(0) instead of caller(1) - RT#121348 - Leg::match check addr also against host - RT#120909 - support for same contact on multiple legs in StatelessProxy, i.e. multiple IP for same domain of contact 0.811 2017-11-06 - Net::SIP::Simple - adhere to rtp_param on listener side too which makes it possible to use custom codecs for both sender and recipient 0.810 2017-08-08 - various fixes based on feedback from Richard Carver: - RT#120816 - account for slightly different Via and Proxy-Authorization in INVITE and CANCEL when computing via_branch - RT#121514: fix race in SocketPool where it tried to send new data during TCP connect or TLS handshake, which resulted in the worst case in data sent in plain instead of encrypted - RT#121347 - fix usage if dict in Net::SIP::Dispatcher::i2legs - RT#121585 - fix encoding special characters in Net::SIP::Util::sip_parts2hdrval - RT#122588 - fix typo in Net::SIP::Debug::level - make it possible to restrict methods when receiving DTMF using param dtmf_methods in Simple::Call, based on feedback from Peter Linden 0.809 2017-03-14 - StatelessProxy: decrease size of resulting new contact in the default rewrite_contact handler to better deal with implementations which severally limit the size of contact headers they accept. Switch _stupid_crypt from mac-then-encrypt to encrypt-then-mac - RT#120593, StatelessProxy now handles rewriting of contacts with no '@' - RT#120039, SocketPool callbacks now include receiving socket object for further analysis, like getting the certificates from the SSL socket - RT#120011, Leg::forward_outgoing - ignore (invalid) Via headers w/o branch - RT#120009, use ReuseAddr additionally to Reuse in IO::Socket* for compatibilty with IO::Socket::IP 0.808 2016-12-13 - make DTMF detection more robust in case of UDP reordering, duplicates etc - make t/19_call_with_dtmf.t more robust on slooow systems - call UA cleanup in tests to reduce warnings at global destruction 0.807 2016-12-07 - fix workaround for IO::Socket::IP from 0.806 - fix DNS resolver fix from 0.806 0.806 2016-12-06 - fixed case in builtin DNS resolver where address records got preference to SRV records - work around IO::Socket::IP behavior on systems with only lo interface 0.805 2016-12-05 - use host argument in Leg::new even if ip and port are extracted from the socket 0.804 2016-12-05 - fix requirement for 5.10.0 in Makefile.PL and SIP.pm 0.803 2016-12-04 - Dispatcher::resolve_uri - fix case with explicit transport - SocketPool: support for requesting client certificate (argument verify_client). Update documentation to include TLS settings. - refuse to build if Socket does not implement inet_pton - spelling fixes from Debian RT#118979 - make it more friendly to cpantesters 0.802 2016-11-25 - various small fixes primarily related to TLS - Util::sip_sockinfo2uri accepts hash for convinience - lots of improvements for code readibility and better documentation based on feedback from BLUHM 0.801 2016-11-23 - bugfix Util::ip_string2parts 0.800 2016-11-23 - added support for TLS (SIPS) when IO::Socket::SSL >= 1.956 is installed - make the requirement for Net::DNS optional, i.e. only needed if actually used for DNS lookups. - fully non-blocking DNS lookups in Dispatcher (dns_host2ip, dns_domain2srv) - new/extended API - easy way to do own DNS resolving with dnsresolv argument to Dispatcher - new function Util::ip_is_v46 - Util ip_string2parts, ip_sockaddr2parts return hash on wantarray and the reverse functions ip_parts2string, ip_parts2sockaddr accept hash reference - Leg->laddr(2) uses hostname instead of IP address - important, partly incompatible API changes - Leg::new and Simple::new now croak when unexpected arguments are given - Internals changed for more code reability and to take care of TLS where the hostname is needed for certificate validatin. Lots of structures are now managed by (restricted) hashes which were previously implemented as arrays. Anybody grabbing in the internals will probably need to adjust code. Affects partly the more public functions of Leg and Dispatcher too. 0.703 2016-11-20 - fix to support Perl 5.14.x and lower 0.702 2016-11-18 - fix wrong TCP connect timeout triggered long after successful connect - fix reading of partial SIP packet with TCP - various small improvements based on feedback from BLUHM 0.701 2016-11-17 - fix TCP async connect 0.700 2016-11-17 - support for TCP - major API changes !!! - proxies, registrars etc are no longer given with udp:/tcp: prefix to signal which protocol gets used but instead SIP URL's are used: sip:... - SIP over UDP sip:...;transport=TCP - SIP over TCP sips:... - SIP over TLS the simplified syntax without protocol specification still works and is considered as before as SIP over UDP - Util: result of sip_uri2parts changed from (domain,user,proto,param,data) to (domain,user,proto,data,param) - Eventloop - addFD, delFD now take argument $rw to specify if the handler is for read or for write. If omitted in delFD it will remove all handlers for fd as before. Wrong (old) usage with addFD will result in Carp::confess. !!! When integrating with its own eventloop this is also the interface this loop is expected to provide !!! - Dispatcher::deliver: arguments dst_addr now [proto,ip,port,family] instead of string. Using string with SIP URI is also still supported but not official API but existing code without protocol specification in string should thus still work. - Endpoint::register expects SIP URI, i.e. no longer adds 'sip:' prefix - fields or meaning of fields in Leg, Packet, Dispatcher::Packet changed but nobody should have accessed these internals anyway - Leg::deliver: destination given as [proto,ip,port,family] instead of ip:port string - Leg::sendto takes packet object instead of packet string, dst as single argument with [host,port,family] instead of separate addr and port arguments - Leg::receive now gets (packet,from) and returns the same (might modify data but currently doesn't). Previously reading of the packet was done inside this function but now reading is done by SocketPool and Leg just has the option to process packet. 0.691 2016-10-31 - various smaller enhancements - added spelling fixes from Debian, RT#118564 0.690 2016-10-30 - fix target hostname vs. IP detection in StatelessProxy with IPv6 0.689 2016-10-28 - some IPv6 fixes and enhancements in parts based on review by BLUHM 0.688 2016-10-26 - support for IPv6 0.687 2014-02-11 StatelessProxy: - better encryption for rewritten contact and way to define its own - fix loop detection 0.686 2014-02-07 - StatelessProxy: rewriting contact now contains information about incoming and outgoing legs to restore the path if somebody uses the rewritten contact for a new request 0.685 2014-02-04 - fix NATHelper::Call::session (wrong argument for callback) - enhance NATHelper::Session to connect sockets if we detect that the peer uses symmetric RTP. Make sure, that even with asymmetric RTP we get the data from always the same peer 0.684 2014-01-27 - add hooks into NATHelper::Base to make it easier to adapt 0.683 2013-10-23 - fix issue with comma inside <..>, thanks to ccjaph[AT]gmail[DOT]com https://rt.cpan.org/Ticket/Display.html?id=89712 0.682_1 2013-09-30 - fixed issue, where incoming sequence number of 0 was seen as duplicate of previous incoming request Thanks to stefano[DOT]pisani[AT]omniavoip[DOT]org - added more meta information to Makefile.PL 0.682 2013-07-29 - add DTMF receiving to Simple::RTP send_recv handler Thanks to stefano[DOT]pisani[AT]omniavoip[DOT]org - enhanced t/19_call_with_dtmf.t 0.681 2013-07-29 - add DMTF media type to SDPs media line in Simple::Call::_setup_local_rtp_sockets. Thanks to stefano[DOT]pisani[AT]omniavoip[DOT]org 0.68 2012-12-17 - https://rt.cpan.org/Ticket/Display.html?id=82041 by dying in Makefile.PL on Win32. Probably only the forking tests will be the problem on windows, but for now I've no motivation to put more efforts in supporting this platform. 0.67 2012-08-29 - fixed https://rt.cpan.org/Ticket/Display.html?id=78979, thanks to Martin Skøtt for reporting - added cb_notify callback to Net::SIP::Simple, which gets triggered when a NOTIFY gets received 0.66_1 2012-07-03 - added method request to Simple::Call, usable to create requests within the context of the current call, like REFER. 0.66 2012-06-26 - fix in DTMF code for perl<5.14 0.65 2012-06-25 - first non-developer release with DTMF support. Reworked some documentation regarding DTMF handling, otherwise same as 0.64_6 - removed t/*fdleak tests for now, because they no longer work on recent linux versions (ubuntu 12.04) which sometimes map /proc/pid/auxv as a file descriptor and thus mix up fd count. Will be added again once the problem is worked around 0.64_6 2012-06-12 - support for DTMF in Net::SIP::Simple : sending and receiving, rfc2833 and audio. See sub dtmf and callback cb_dtmf. 0.64_5 2012-05-06 - add info about final response to most of the cb_final callbacks based on idea from r[DOT]molle[AT]teles[DOT]de 0.64_4 2012-04-17 - to modify request before authorized response one can now first issue request w/o authorization, catch the 401/407 response within the cb_final and then reissue the request including the response containing the authorization request as resp40x parameter 0.64_3 2012-03-17 - add response packet to final callback when registration failed in Simple::register. Can be used to to preflight registration in case of NAT and to extract received_addr etc from response. based on idea from r[DOT]molle[AT]teles[DOT]de 0.64_2 2012-03-17 - if contact is given for leg use it for the default contact in INVITE requests and 2xx responses instead of addr:port, based on idea from r[DOT]molle[AT]teles[DOT]de 0.64_1 2012-01-13 - let Net::SIP::Simple invite and register define the callid for the connection, based on idea from r[DOT]molle[AT]teles[DOT]de 0.64 2011-10-25 - in stateless proxy: if incoming leg and outgoing leg are different add via header for incoming leg and use it when response comes in to find the outgoing leg for the response 0.63 2011-10-10 - just call 0.62_12 0.63 because the last stable was released long ago 0.62_12 2011-10-07 - authorization infos gets copied to new call object if INVITE was received. - add create_auth to Net::SIP::Simple, fix authorization for registrar (only on REGISTER) - add cb_invite callback to Net::SIP::Simple::Call, which gets triggered on reinvite from peer - added more samples below samples/ directory 0.62_11 2011-09-11 - add authorization to listen, registrar, proxy - add test for invite+reinvite+bye with authorization - fix so that ACK and CANCEL reuse authorization from INVITE 0.62_10 2011-08-26 - reorder actions in Endpoint::Context::handle_response, so that response requesting authorized BYE gets handled with authorized BYE instead of ignoring it. Thanks to Roland Mas lolando[AT]debian[DOT]org for reporting the problem. 0.62_9 2011-05-17 - clarify behavior for bad packets in documentation (e.g. throw exception) 0.62_8 2011-05-13 - deal with mailformed SDP body in Net::SIP::Simple::Call, e.g. catch error and ignore packet instead of letting the application die. Thanks to vitspec[AT]gmail[DOT]com reporting the problem. 0.62_7 2011-05-02 - fix Dispatcher::add_leg for arguments IO::Handle and Hash. Thanks to DetlefPilzecker[AT]web[DOT]de for reporting 0.62_6 2011-04-15 - fix UAC behavior for response to REGISTER in Net::SIP::Simple::register Thanks to dmw for reporting http://cpanforum.com/posts/13305 0.62_5 2011-03-08 - fix to Net::SIP::Authorize::FromIsRealm. Here was not only the domain part compared to the realm but additionally the port if the sender was given as sip:user@host:port Thanks to DetlefPilzecker[AT]web[DOT]de for reporting 0.62_4 2011-02-14 - on permanent delivery failure callback was called within context with wrong order of arguments. Thanks to james[AT]bolderthinking[DOT]com for reporting problem. 0.62_3 2011-02-03 - track which method started context and close context on final response (>=200) unless method was INVITE. Thanks to james[AT]bolderthinking[DOT]com for reporting problem. 0.62_2 2011-02-03 - changes to Net::SIP::Dropper* based on feedback from DetlefPilzecker[AT]web[DOT]de 0.62_1 2011-01-18 - add Net::SIP::Dropper incl. ...Dropper::{ByIPPort,ByField} based on a lot of input and code from DetlefPilzecker[AT]web[DOT]de 0.62 2010-12-06 - overwrite route header from record-route only for 200 response which established dialog, not for further responses Thanks to vitspec[AT]gmail[DOT]com for reporting. 0.61 2010-12-06 - overwrite route header from record-route only for first INVITE in context, not for re-INVITEs. Thanks to vitspec[AT]gmail[DOT]com for reporting. 0.60 2010-11-30 - overwrite route header from record-route only for INVITE. Thanks to vitspec[AT]gmail[DOT]com for reporting. 0.59_11 2010-11-02 - overwrite a given route header for any new request if there is already a route information for the given context. Thanks to vitspec[AT]gmail[DOT]com for reporting. 0.59_10 2010-11-01 - the route header in ACK must be set to the route it got by record-route from the response (if any), instead of using the route from the INVITE. Thanks to vitspec[AT]gmail[DOT]com for reporting the bug. 0.59_9 2010-09-09 - bugfix rport handling by DetlefPilzecker[AT]web[DOT]de - clarify documentation of Net::SIP::Packet, e.g. that it die()s if it cannot parse string as SIP packet 0.59_8 2010-08-20 - fixes to 0.59_7 from DetlefPilzecker[AT]web[DOT]de - added documentation for filter in Authorize 0.59_7 2010-08-17 - additional authorization based on idea of DetlefPilzecker[AT]web[DOT]de 0.59_6 2010-08-09 - fix unitialized warning in Authorize if user neither in user2a1 nor in user2pass. - dispatcher: add recieved + rport to via only for requests - Thanks again to DetlefPilzecker[AT]web[DOT]de 0.59_5 2010-08-09 - fix Registrar to get the address for registration from 'To' header, not 'From' header. Thanks again to DetlefPilzecker[AT]web[DOT]de 0.59_4 2010-08-08 - fix rport handling. Thanks again to DetlefPilzecker[AT]web[DOT]de 0.59_3 2010-07-26 - fix Via:..;received= handling - should by IP of sending host, not of receiving leg. Moved setting it to dispatcher, and set target addr from received in Statelessproxy instead of lookup for leg with this addr. Thanks again to DetlefPilzecker[AT]web[DOT]de - added rport support to Via header (RFC 3581) 0.59_1 2010-07-22 - Leg: Via..received= should only contain ip, not ip:port. Thanks to DetlefPilzecker[AT]web[DOT]de for pointing out. Fix Leg and StatelessProxy (where it expects to get port) 0.59 2010-07-12 - Dispatcher::cancel_delivery returns true if delivery was canceled - Blocker blocks all ACKS if all INVITE will be blocked, no mattter if the response is in delivery queue. Thanks to DetlefPilzecker[AT]web[DOT]de 0.58_11 2010-07-09 - fix for Blocker + test from DetlefPilzecker[AT]web[DOT]de 0.58_10 2010-06-24 - if qop=auth,auth-int given respond with qop=auth 0.58_9 2010-06-24 - Endpoint::Context::request_delivery_done - do not remove transaction, because in case of tcp delivery done will be called once request is send. transaction will be removed in handle_response already 0.58_8 2010-06-24 - Request::authorize - accept qop="auth,auth-int".., e.g. es long auth is specifified its ok. Based on Bug report from alain[AT]knaff[DOT]lu 0.58_7 2010-06-11 - removed unused field outgoing_leg from Net::SIP::Dispatcher. Thanks to DetlefPilzecker[AT]web[DOT]de for pointing this out 0.58_6 2010-06-02 - fixes on Authorize.pm based on reports from DetlefPilzecker[AT]web[DOT]de: - cancel_delivery in Authorize on ACK 0.58_4 2010-05-31 - fixes on Redirect.pm based on reports from DetlefPilzecker[AT]web[DOT]de: - respond 200 to CANCEL - redirect everything except REGISTER, not only INVITE 0.58_3 2010-05-31 Based on patches from DetlefPilzecker[AT]web[DOT]de - Net::SIP::Request::create_response - msg is optional, if not given a builtin msg for the code will be used. - new functionality: Net::SIP::Blocker provides way to block requests by method name with custom code 0.58_2 2010-05-31 - fix Net::SIP::Simple::register, so that it uses an explicitly given contact unchanged. Bug report by stefano[DOT]pisani[AT]omnianet[DOT]it 0.58_1 2010-05-28 various fixes based on feedback and patches from DetlefPilzecker[AT]web[DOT]de - check authorization for CANCEL not only against INVITE:uri but also against CANCEL:uri. The RFC is not specific in this area - Authorize: don't forward unauthorized ACKs - ReceiveChain: filter callback need not to be code ref, especially if methods arg was used. Now called with invoke_callback instead 0.58 2010-04-15 - with 'perl -MNet::SIP=rtp:min-max' the ports to used for RTP can be restricted, useful if behind firewall with limited forwarding. See Net::SIP doku for more information. Thanks to DetlefPilzecker[AT]web[DOT]de for pointing out the problem. 0.57_4 2010-04-15 - Net::SIP::Endpoint::Context - set context.to based on reply before invoking callback. Thanks for input. 0.57_3 2010-04-15 - Net::SIP::Leg::receive: ignore packets with len<13 because any valid packet must be larger. Such packets are used for keep-alives. Thanks to DetlefPilzecker[AT]web[DOT]de for pointing out the problem. 0.57_2 2010-04-13 - added Net::SIP::Simple::Call::get_param as pendant to set_param based on patch from 0.57_1 2010-04-13 - dispatcher calls receive callback with eval so that it does not die on bad or unexpected packets. Thanks to for pointing out the problem 0.57 2010-03-19 - save remote_contact from successful responses in context and use them as remote-URI in new requests. Thanks to for pointing out the problem. 0.56 2010-02-02 - fix CANCEL handling: instead of closing the context immediately: - server should return 487 to client before closing the context - server should ignore ACKs for unknown contexts instead of replying with 481 - client should not close context after CANCEL but wait for response too invite (probably 487) so that it can ACK it - extend t/11_invite_timeout.t to test for the behavior - thanks to for pointing out the problems. 0.55_1 2010-02-02 - add samples/register_and_redirect.pl 0.55 2010-01-27 - Net::SIP::Redirect provides functionlity to redirect INVITES using information from registrar. Sample program samples/register_and_redirect.pl - fixes for Net::SIP::Authorize if no pass is known for user (or user is not known). - fixes for Net::SIP::Authorize for ACK an CANCEL (no challenge possible, credentials should be compared against INVITE method) 0.54 2009-09-04 - bugfix in Net::SIP::Packet::new_from_parts when the header was already given as list of Net::SIP::HeaderPair objects 0.53 2009-01-26 - add Option force_rewrite to Net::SIP::StatelessProxy so that it rewrites the contact even if incoming and outgoing legs are the same 0.52 2008-12-17 - removed changes from 0.47 - if 2xx response to INVITE contains contact header this is used as the base for the request-URI in ACK, not the one from the original INVITE 0.51 2008-12-16 - get to+tag from 2xx response on invite only when call is outgoing, e.g. not on re-INVITE from UAS where UAC send initial INVITE 0.50 2008-10-31 - release 0.49_3 as 0.50 0.49_3 2008-10-29 - Net::SIP::StatelessProxy - observe maddr of URI when forwarding 0.49_2 2008-10-29 - Net::SIP::Dispatcher - observe maddr and transport parameter of URI when finding peer 0.49_1 2008-10-23 - fixed code in Net::SIP::Simple::RTP where it dropped packets (and subsequently terminated the connection due to inactivity) when the 16bit RTP sequence counter overflowed 0.49 2008-09-30 - fixed Socket6::inet_pton based check for valid IP6 address in Net::SIP::SDP 0.48_1 - fix bugs reported by gilad[AT]summit-tech[DOT]ca: - force Allow and Supported header only on INVITE req and 2xx response to INVITE, on 2xx responses to OPTIONS and on 405 responses - force Contact header only on INVITE req and it's 2xx response 0.48 - new function Net::SIP::Util::sip_uri_eq to check if two URIs mean the same - fix bugs reported by gilad[AT]summit-tech[DOT]ca: - when comparing Route header in incoming/outgoing request with myself use sip_uri_eq instead of simple eq, because the URIs might be the same, but one might specify a default port while the other not - when adding record-route header in forward_outgoing check that the top record-route header isn't myself (in case incoming and outgoing leg are the same) 0.47 - if contact header changes the URI of the dialog send the ACK with the original URI of the INVITE and change the dialogs URI afterwards 0.46 - support for canceling a call after some time of ringing based on input from http://rt.cpan.org/Ticket/Display.html?id=34576 see Net::SIP::Simple::Call documentation for sub reinvite, parameters ring_time, cb_noanswer. See also method cancel in this package feature gets used in samples/invite_and_send.pl too - fix for t/*_fdleak for platforms, which use 2 fd for tempfiles (see http://rt.cpan.org/Ticket/Display.html?id=35485). Now it allocates a new fd simply by dup()ing STDOUT - fix in Net::SIP::Dispatcher::Eventloop in case the select returned because of EINTR - fixes in handling response in Net::SIP::Endpoint::Context for the case, that multiple requests shared the same tid (e.g. INVITE,CANCEL) - support for user2a1 instead of user2pass in Net::SIP::Authorize based on input from Alex Revetski http://rt.cpan.org/Ticket/Display.html?id=34648 0.45 - Net::SIP::Packet::sdp_body - content type is case insensitive, accept application/SDP etc - more debug statements - Dispatcher::EventLoop::addFD 3rd arg name of callback to aid debugging - Net::SIP::SDP - better check for IP6 address - Leg: allow multiple contact header in request/response - StatelessProxy: - rewrite contact header only if incoming_leg!=outgoing_leg, - let it actuall define external rewrite function - prefix user in default rewrite contact with 'r' so that it does not look like phone number and doesn't irritate rewriting - fix rewriting, so that user part does not need to be \w+ - split __forward_request into __forward_request_getleg and __forward_request_getaddr for better subclassing - reduce <..> into .. in route before processing it - Registrar: - update all contact information at once, don't combine information from different register requests - access to internal store, to save/restore it from disk with bin/stateless_proxy.pl - fix and extend bin/stateless_proxy.pl - add rewriting, e.g. 0XXX gets forward as XXX to host - restore/save registry data on start/exit - rework lots of code - Net::SIP::Debug: import can set debug function, level and export function within the same call - bugfix Net::SIP::Endpoint::Context::handle_response, see http://rt.cpan.org/Ticket/Display.html?id=35121 0.44 - Net::SIP::Packet::get_header: if called in scalar to get the only one value and we have multiple values try if they are all the same and in this case return the uniq value instead of croaking Works around bug in proxy which issued two content-length headers with the same length as reported in http://rt.cpan.org/Ticket/Display.html?id=33592 - fix test skip in t/*fdleak.t 0.43 - enforce codec 0 PCMU/8000 in outgoing SDP generated based on incoming SDP, don't just accept all codecs the other party offers because Net::SIP::Simple can only PCMU/8000 - make header names per default ucfirst (Via not via) - add default allow and supported headers to INVITE requests and 2xx responses if none where given - fix bug indroduced in 0.42, where contact from incoming INVITE was not used as URI for outgoing BYE for the call 0.42 - on 2xx responses set the URI of the dialog to the contact given in the response. For 302 retry the request with the URI set to the contact given in the 302 response. - make sure that the right contact header is set. for outgoing invites and 2xx responses to invite combine the user part from the sender ('from' for requests, 'to' for responses) with addr and port from the outgoing leg - unless the contact was explicitly set. - if a contact header was given in Net::SIP::Simple which had a port specification the port would be duplicated, e.g. user@ip:port:port 0.41 - give 'contact' header to Net::SIP::Simple which is then used for invite and register - more checks of data when parsing SIP header, more knowledge about keys, where the values cannot be comma-seperated (http://rt.cpan.org/Public/Bug/Display.html?id=31236) - fix wrong call of ok() in t/03_forward_stateless - fix http://rt.cpan.org/Public/Bug/Display.html?id=31284 (Net::SIP::Request::set_uri did not update string representation) 0.40 - Net::SIP::Simple::RTP - when sending data from file set the timestamp based on sequence number and packet size ( == samples in packet for 8bit) - set Via header correct in the case of udp and port 5061. No longer set Via based on contact header, base it only on address of leg - primitive support for other codecs in Net::SIP::Simple, see rtp_param in Net::SIP::Simple::Call 0.39 - work around missing support for non-blocking sockets in IO::Socket on MSWin32 platform - fix http://rt.cpan.org/Ticket/Display.html?id=30691 where the same realm was authorized again and again if the given user/pass where wrong 0.38 - fix dns lookup problem for SRV records. Instead of using the IP it used the service name (e.g. _sip._udp....) as the target of the packet - bin/answer_machine.pl - crude attempt to create filenames which don't have chars special to windows ('<',...) 0.37 - Endpoint::close_context now cancel all outstanding deliveries for this context in the dispatcher. Extented queue objects and Dispatcher::cancel_delivery to make this possible - tests for file descriptor leaks (09_fdleak.t,10_fdleak.t) - some more Scalar::Util::weaken for callbacks in Simple::Call to stop circular references 0.36 - small performance improvements for Net::SIP::Simple::RTP and samples/bench - fixed race condition on Net::SIP::Dispatcher::Eventloop (e.g one callback disabled fd, but it tried to call callback for the disabled fd) - added Net::SIP::Simple::cleanup and made some references to the objects within callbacks weak, so that no objects and file descriptors would leak if properly used 0.35 - Net::SIP::Simple::Call - close call context in $call->cleanup, otherwise it could leak file descriptors if the call wasn't closed clean (with BYE or CANCEL). - new test applications for simple benchmarks in samples/bench - documentation: new file samples/README describes the files in samples/ 0.34 - Net::SIP::Simple: handle OPTIONS requests. These are for instance used by Asterisk to determine if the registered party accepts incoming calls. 0.33 - fix rt#29153 in StatelessProxy.pm ($1 from prev regex used after call of user function, which could change it) - Endpoint::new_response - make sure that 2xx responses to INVITE carry a contact header 0.32 - Net::SIP::Registrar checks on non-REGISTER requests if the target it registered with itself and then rewrites the URI in the packet. This can be used for a combined Registar+Proxy, see samples/test_registrar_and_proxy.pl - samples/invite_and_*.pl have now option -L|--leg to specify a local address 0.31 - make it usable for perl5.9, tested with 5.9.5 0.30 - Option cb_preliminary for Simple::Call:reinvite to specify callback which will be triggered when preliminary response is received more parameter for cb_create in Simple::listen, so that it can create a response (like 180 Ringing) to the peer see documentation and the adapted t/02_listen_and_invite.t 0.29 - make sure that max-forwards is added to every Request from the endpoint and that all INVITE have a contact header because these are mandatory according to RFC - invoke 'filter' callback in Net::SIP::Simple::listen with the Request object as an additional argument, cb_create callback in listen needs to return TRUE or the call will be closed !!!! Warning: this might break code which did not return TRUE from cb_create !!!!! 0.28 - Request.pm - make sure that nc-count is send when authorizing and qop was set. This is required according to rfc2617 0.27 - Authorize.pm, Request.pm - support 'opaque' field in digest authorization (when authorizing or when requesting authorization) 0.26 - SDP.pm - fix regex for IP4 which did not include all IPv4 addr 0.25 - small fixes to SDP - added concept of chains, e.g. put an Authorize object in front of Registrar inside a ReceiveChain and all REGISTER requests will be authorized, see Net::SIP::{Authorize,ReceiveChain} - StatelessProxy can no longer have an internal Registrar. use ReceiveChain to put a Registrar in front of the proxy instead - new test t/08_register_with_auth.pl to test Authorize and ReceiveChain - fix Request::authorize 0.24 - make adding commands to NATHelper::Server easier - add user params for NATHelper::Session during activate_session - SDP: make sure that IP4/IP6 is valid IP - small fixes 0.23 - fix memleak in NATHelper::Base - support for derived NATHelper::Base in NATHelper::Server - update docu for NATHelper::Base::expire 0.22 - enforce perl5.8 and prerequisite Net::DNS in Makefile.PL - NATHelper::Base - more controling of resource usage with max_sockets and max_sockets_in_group and/or by redefining (un)get_rtp_sockets 0.21 - new sample samples/3pcc.pl for 3rd party call control - small fixes 0.20 - enhancements on tests, new tests for reinvite and call on hold - lots of bugfixes: re-invites, NAT, call on hold, branch tag on via and 'tag' on to|from in responses, max-forwards handling, response caching in dispatcher.... - set route from record-route in responses, use route header in dispatching outgoing requests - early loop detection for outgoing packets - new param call_on_hold for Net::Simple::Call to set call on hold on reinvite... 0.18 - NATHelper::* changes in the return values of expire, close_session, activate_session to aid logging of sessions (see updated doc) - NATHelper::Local has smarter _update_callbacks - bugfixes, especially on Net::Simple regarding handling of re-invites in existing call - new test t/06_call_with_reinvite.t 0.17 - added documentation for Net::SIP::NATHelper::* - updated doc for Net::SIP::StatelessProxy regarding NAT - added HOWTO with some Q+A - added COPYRIGHT - new method 'method' in Net::SIP::Response - small bugfixes 0.16 - lots of bugfixes - removed leg2proxy and domain2leg from Net::SIP::Dispatcher again because they do not fit into concept, see bin/stateles_proxy.pl how to achieve similar things - lot of bugfixes, changes and enhancement on StatelessProxy - Net::SIP can now export useful things, see doc - a lot of enhancements for NAT, implementation of local (inside process) and remote NAT helpers which forward RTP data - Net::SIP::Dispatcher: lookup for A an SRV records now in seperate, callback oriented method (which are not asynchronous yet, but have an asynchronous interface) - moved real world usable programs from samples/ to bin/ - more tests, samples/ and bins/ 0.15 - various bugfixes - limit Max-Forwards header to 70 while forwarding packets for security reasons (to avoid bad clients which will set it to something very high and then try to force loop) - do not add Record-Route header to REGISTER requests - major changes and enhancements on Net::SIP::StatelessProxy - rename Net::SIP::Dispatcher::Eventloop::addTimer to add_timer so that it is the same name like in the other modules - Net::SIP::Simple: way to add explicit Route headers# - new package Net::SIP::NATHelper do aid in the writing of SIP proxies which do NAT (no documentation yet) - support for debug levels in Net::SIP::Debug sample scripts support various debug levels, see doc to Net::SIP::Debug for meaning of different levels - samples/stateless_proxy.pl as sample implementation for slightly complex stateless proxy (not fully tested yet) - new function sip_uri2parts in Net::SIP::Util - ways to specify custom headers in Net::SIP::Simple using option 'sip_header' - new keys domain2leg and leg2proxy in Net::SIP::Dispatcher which influence routing - new method resolve_uri in Net::SIP::Dispatcher to asnychronously resolve URI (was __resolve_uri, but now public with slightly different interface) - new test 03_forward_stateless which tests parts of routing for stateless proxy 0.14 - forgot to include samples to MANIFEST, this is fixed now so that they get included into the distribution 0.13 - samples/answer_machine.pl as a sample implementation of an answer machine - new methods peer in Net::SIP::Endpoint::Context and get_peer in Net::SIP::Simple::Call - fix inactivity timeout for media_recv_send in Net::SIP::Simple::RTP - media_send_recv, media_recv_echo in Net::SIP::Simple::RTP can use callback for read/write data instead of filenames 0.12 - samples/invite_and_send.pl as new sample client which can invite and send multiple voice file to peer (using re-invites) - various small bug fixes 0.11 - samples/invite_and_recv.pl as new sample client which can invite and record a message - various small features and bug fixes 0.1 - first public version Net-SIP-0.822/bin/0000755000175100017510000000000013552315100012177 5ustar workworkNet-SIP-0.822/bin/README0000644000175100017510000000107211136273030013060 0ustar workworkanswer_machine.pl * answer machine which can play a welcome message and record calls * can handle multiple calls in parallel stateless_proxy.pl * not so simple stateless proxy which will forward SIP packets between legs * can forward based on destination domain * can have registrars on legs and forward to registered clients * can do NAT either in-process or together with nathelper.pl nathelper.pl * standalone process to rewrite proxy RTP connections * works together with stateless_proxy.pl or anything else which uses Net::SIP::NATHelper::Server Net-SIP-0.822/bin/answer_machine.pl0000644000175100017510000001303312271423166015530 0ustar workwork########################################################################### # Simple answer machine: # - Register and listen # - On incoming call send welcome message and send data to file, hangup # after specified time # - Recorded data will be saved as %d_%s_.pcmu-8000 where %d is the # timestamp from time() and %s is the data from the SP 'From' header. # to convert this to something more usable you might use 'sox' from # sox.sf.net, e.g for converting to OGG: # sox -t raw -b -U -c 1 -r 8000 file.pcmu-8000 file.ogg # - Recording starts already at the beginning, not after the welcome # message is done ########################################################################### use strict; use warnings; use IO::Socket::INET; use Getopt::Long qw(:config posix_default bundling); use Net::SIP; use Net::SIP::Util ':all'; use Net::SIP::Debug; sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, 'R|registrar=s' => \$registrar, 'W|welcome=s' => \$welcome, 'D|savedir=s' => \$savedir, 'T|timeout=i' => \$hangup, 'username=s' =>\$username, 'password=s' =>\$password, ) || usage( "bad option" ); Net::SIP::Debug->level( $debug || 1 ) if defined $debug; my $from = shift(@ARGV); $from || usage( "no local address" ); $welcome ||= -f $welcome_default && $welcome_default; $welcome || usage( "no welcome message" ); ################################################### # if no proxy is given we need to find out # about the leg using the IP given from FROM ################################################### my $leg; if ( !$registrar ) { my ($host,$port) = $from =~m{\@([\w\-\.]+)(?::(\d+))?} or die "cannot find SIP domain in '$from'"; my $addr = gethostbyname( $host ) || die "cannot get IP from SIP domain '$host'"; $addr = inet_ntoa( $addr ); $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => $port || 5060, ); # if no port given and port 5060 is already used try another one if ( !$leg && !$port ) { $leg = IO::Socket::INET->new( Proto => 'udp', LocalAddr => $addr, LocalPort => 0 ) || die "cannot create leg at $addr: $!"; } } ################################################### # SIP code starts here ################################################### # create necessary legs my @legs; push @legs,$leg if $leg; if ( $registrar ) { if ( ! grep { $_->can_deliver_to( $registrar ) } @legs ) { my $sock = create_socket_to($registrar) || die "cannot create socket to $registrar"; push @legs, Net::SIP::Leg->new( sock => $sock ); } } # create user agent my $ua = Net::SIP::Simple->new( from => $from, legs => \@legs, $username ? ( auth => [ $username,$password ] ):(), ); # optional registration if ( $registrar ) { my $sub_register; $sub_register = sub { my $expire = $ua->register( registrar => $registrar ) || die "registration failed: ".$ua->error; # need to refresh registration periodically DEBUG( "registered \@$registrar, expires=$expire" ); $ua->add_timer( $expire/2, $sub_register ); }; $sub_register->(); } # listen $ua->listen( init_media => [ \&play_welcome, $welcome,$hangup,$savedir ], recv_bye => sub { my $param = shift; my $t = delete $param->{stop_rtp_timer}; $t && $t->cancel; } ); $ua->loop; ################################################### # sub to play welcome message, save the peers # message and stop the call after a specific time ################################################### sub play_welcome { my ($welcome,$hangup,$savedir,$call,$param) = @_; my $from = $call->get_peer; my $filename = sprintf "%d_%s_.pcmu-8000", time(),$from; $filename =~s{[/<>:\.[:^print:]]}{_}g; # normalize DEBUG( "call=$call param=$param peer=$from filename='$filename'" ); $filename = $savedir."/".$filename if $savedir; # callback for sending data to peer my ($fd,$lastbuf); my $play_welcome = sub { $fd || open( $fd,'<',$welcome ) || die $!; if ( read( $fd, my $buf,160 )) { # still data in $welcome $lastbuf = $buf; return $buf; } else { # no more data in welcome. Play last packet again # while the peer is talking to us. return $lastbuf; } }; # timer for restring time the peer can speak $param->{stop_rtp_timer} = $call->add_timer( $hangup, [ sub { DEBUG( "connection closed because record time too big" ); shift->bye }, $call ]); my $rtp = $call->rtp( 'media_send_recv', $play_welcome,1,$filename ); return invoke_callback( $rtp,$call,$param ); } Net-SIP-0.822/bin/stateless_proxy.pl0000644000175100017510000003167012271424737016031 0ustar workwork########################################################################### # Stateless proxy # listens on multiple legs and forwards SIP packets between the legs # TODO: do NAT ########################################################################### use strict; use warnings; use IO::Socket::INET; use Getopt::Long qw(:config posix_default bundling); use List::Util 'first'; use Net::SIP; use Net::SIP::Util ':all'; use Net::SIP::Debug; use Net::SIP::NATHelper::Local; use Storable; $SIG{TERM} = $SIG{INT} = sub { exit(0) }; sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < @domains ? [ @domains ] : undef, prefix => %prefix ? { %prefix }: undef, registrar => $be_registrar, proxy => $proxy, }; (@domains,%prefix,$be_registrar,$proxy) = (); } $leg = $val; }; GetOptions( 'd|debug:i' => \$debug, 'h|help' => sub { usage() }, 'rdump=s' => \$rdump, 'nathelper' => \$nathelper, 'L|leg=s' => $check_leg, 'r|registrar' => \$be_registrar, 'D|domain=s' => \@domains, 'P|proxy=s' => \$proxy, 'X|prefix=s' => sub { my ($prefix,$domain) = $_[1] =~m{^(\d+)=(\w[\w\-\.]+)$} or usage( "bad prefix $_[1]" ); $prefix{$prefix} = $domain; }, ) || usage( "bad option" ); $check_leg->(); #final call Net::SIP::Debug->level( $debug || 1 ) if defined $debug; %legs or usage( 'no addr to listen' ); ################################################### # create Legs ################################################### my (%domain2leg,%leg2proxy,%leg2rewrite); while ( my ($addr,$opt) = each %legs ) { my $leg = $opt->{leg} = Net::SIP::Leg->new( addr => $addr ); foreach my $dom (@{ $opt->{domains} }) { $domain2leg{$dom} = $leg; $leg2proxy{$leg} = $opt->{proxy} if $opt->{proxy}; } if ( my $p = $opt->{prefix} ) { my %p = %{ $opt->{prefix} }; # longest prefix first my @pf = sort { length($b) <=> length($a) } keys %p; $leg2rewrite{$leg} = sub { my ($user,$dom) = @_; $user or return; DEBUG( 50,"try to rewrite $user\@$dom, pf=@pf" ); for my $pf (@pf) { if ( $user =~m{^\Q$pf\E(.+)} ) { return ($1,$p{$pf}); } } return; }; } } ################################################### # create Dispatcher ################################################### my $loop = Net::SIP::Dispatcher::Eventloop->new; my $disp = Net::SIP::Dispatcher->new( [ map { $_->{leg} } values(%legs) ], $loop, ); $nathelper = $nathelper && Net::SIP::NATHelper::Local->new($loop); ################################################### # create Registrars on the legs and wraps them # together into on object ################################################### my %savereg; END { $rdump or return; Storable::store( \%savereg,$rdump ); } my %registrar; if ( my $regdata = $rdump && -f $rdump && Storable::retrieve($rdump)) { %savereg = %$regdata } foreach my $opt ( values %legs ) { $opt->{registrar} or do { DEBUG( 50,"no registrar on leg $opt->{leg} ".$opt->{leg}->dump ); next; }; my $reg = $registrar{ $opt->{leg} } = Net::SIP::Registrar->new( dispatcher => $disp, domains => $opt->{domains}, #min_expires => 1, #max_expires => 15, ); DEBUG( 50,"create registrar on leg $opt->{leg} ".$opt->{leg}->dump." for domains @{$opt->{domains}}" ); my $key = $opt->{leg}->dump; $reg->_store( $savereg{$key} ||= {} ); } my $registrar = %registrar ? myRegistrar->new( %registrar ) : undef; ################################################### # create StatelessProxy ################################################### my $stateless_proxy = myProxy->new( dispatcher => $disp, domain2leg => \%domain2leg, leg2rewrite => \%leg2rewrite, leg2registrar => \%registrar, leg2proxy => \%leg2proxy, nathelper => $nathelper, ); if ( $registrar ) { # create chain, where first the registrar gets the packet # and the proxy will handle it only, if the registrar # does not handle it my $chain = Net::SIP::ReceiveChain->new( [ $registrar, $stateless_proxy ] ); DEBUG( 50,"set receiver to $chain" ); $disp->set_receiver( $chain ); } else { DEBUG( 50,"set receiver to $stateless_proxy" ); $disp->set_receiver( $stateless_proxy ); } ################################################### # run.. ################################################### $loop->loop; ################################################### ################################################### # # myRegistrar contains multiple registrars # the receive method checks based on the incoming # leg, if one of the registrars is responsable # it will not be queried, this will be done on # the single registrars # ################################################### ################################################### package myRegistrar; use Net::SIP::Debug; sub new { my ($class,%hash) = @_; # Net::SIP::Registrar objects indexed by string # representation of leg return bless \%hash,$class } sub receive { my myRegistrar $self = shift; my ($packet,$leg,$addr) = @_; return unless $packet->is_request and $packet->method eq 'REGISTER'; DEBUG( 50,"Registrar got ".$packet->dump ); # return undef if not registrar for leg, otherwise # let it handle by the registrar object my $reg = $self->{$leg} || return; return $reg->receive( @_ ); } ################################################### ################################################### # # myProxy # special handling for domain2leg and registrars # on the leg and for rewriting leg2rewrite and # setting dst with leg2proxy # ################################################### ################################################### package myProxy; use base 'Net::SIP::StatelessProxy'; use Net::SIP::Debug; use Net::SIP::Util ':all'; use fields qw( domain2leg leg2registrar leg2rewrite leg2proxy ); sub new { my ($class,%args) = @_; my $d2l = delete $args{domain2leg}; my $reg = delete $args{leg2registrar}; my $rewrite = delete $args{leg2rewrite}; my $l2p = delete $args{leg2proxy}; my $self = $class->SUPER::new( %args, rewrite_contact => \&_rewrite_contact, ); $self->{domain2leg} = $d2l; $self->{leg2registrar} = $reg; $self->{leg2rewrite} = $rewrite; $self->{leg2proxy} = $l2p; return $self; } # QUICK and DIRTY caching of contact rewrites { my ($cache,$cache_old,$trotate,$random); sub _rewrite_contact { my ($contact) = @_; my $now = time(); if ( ! $trotate || $now - $trotate > 600 ) { $cache_old = $cache; $trotate = $now; } my $hit = $cache->{$contact}; if ( ! $hit && ( $hit = $cache_old->{$contact})) { # refresh cache $cache->{$contact} = $hit } $hit and do { DEBUG( 50,"rewrote $contact -> $hit" ); return $hit }; $contact !~m{\@} and do { # no hit for rewrite back found DEBUG( 50,"no rewrite back for $contact found" ); return; }; # create new rewrite $random ||= rand( 2**32 ); for( my $try = 0;$try < 1000; $try++ ) { my $rw = sprintf "%x.%x",rand(2**32),$random; next if $cache->{$rw} || $cache_old->{$rw}; $cache->{$rw} = $contact; $cache->{$contact} = $rw; DEBUG( 50,"rewrite $contact -> $rw (NEW)" ); return $rw; } DEBUG( 50,"rewrite failed, cache too full..." ); return; } } # FIXME: move to Net::SIP::Util # reverse to sip_uri2parts sub sip_parts2uri { my ($domain,$user,$sip_proto,$param) = @_; my $uri = "$sip_proto:$user\@$domain"; return sip_parts2hdrval( 'to',$uri,$param ) } sub __forward_request_getleg { my myProxy $self = shift; my $entry = shift; my $packet = $entry->{packet}; # rewrite packet if ( my $lrw = $self->{leg2rewrite} ) { if ( my $rw = $lrw->{$entry->{incoming_leg}} ) { DEBUG( 50,"rewrite URI in request\n".$packet->dump ); # rewrite URI # FIXME: this works only for RFC3261 conform requests! my $uri = $packet->uri; my ($domain,$user,$sip_proto,undef,$param) = sip_uri2parts($uri); if ( ($user,$domain) = $rw->($user,$domain) ) { my $new_uri = sip_parts2uri( $domain,$user,$sip_proto,$param); DEBUG( 50,"rewrite URI $uri to $new_uri" ); $packet->set_uri($new_uri); } } else { DEBUG( 50,"no rewriting" ); } } if ( my @r = $packet->get_header( 'route' )) { # default routing DEBUG( 50,"have route header, no special handling" ); $entry->{has_route} = 1; return $self->SUPER::__forward_request_getleg( $entry ) } my ($domain,$user,$sip_proto,undef,$param) = sip_uri2parts($packet->uri); my $d2l = $self->{domain2leg}; my $disp = $self->{dispatcher}; my @legs; # list of possible outgoing legs if ( $d2l && %$d2l ) { ##### special routing based on domain2leg DEBUG( 50,"special routing based on domain2leg, domain=$domain" ); my $dom = $domain; my $leg = $d2l->{$dom}; # exact match while ( ! $leg) { $dom =~s{^[^\.]+\.}{} or last; $leg = $d2l->{ "*.$dom" }; } $leg ||= $d2l->{ $dom = '*'}; # catch-all if ( ! $leg ) { DEBUG( 50,"no leg found for domain $domain" ); # limit to legs for which I have no domain2leg mapping my %legs = map { $_ => $_ } @{ $disp->{legs} }; delete @legs{ values %$d2l }; @legs = values %legs; } else { DEBUG( 50,"found leg=".$leg->dump." for domain $domain" ); @legs = $leg } if ( ! @legs ) { # no available legs -> DROP DEBUG( 2,"no leg for domain $domain and no legs w/o domain -> DROP ".$packet->dump ); return; } } if ( my $l2r = $self->{leg2registrar} ) { #### try if the registrar has the address on some leg #### if, then set the outgoing leg and rewrite the packet to #### reflect the new URI my @reg = @legs ? @{$l2r}{@legs} : values %$l2r; for my $leg ( @legs ? @legs : values %$l2r ) { my $reg = $l2r->{$leg} or next; DEBUG( 10,"query registrar for $sip_proto:$user\@$domain" ); my @addr = $reg->query( "$sip_proto:$user\@$domain" ) or next; $packet->set_uri( $addr[0] ); @legs = grep { $_ eq $leg } @{ $disp->{legs}}; last; } } @{ $entry->{outgoing_leg}} = @legs; return $self->SUPER::__forward_request_getleg( $entry ); } sub __forward_request_getdaddr { my myProxy $self = shift; my $entry = shift; my $legs = $entry->{outgoing_leg}; # if leg was given by route try to check for Registrar there if ( @$legs && $entry->{has_route} && ( my $reg = $self->{leg2registrar}{$legs->[0]} )) { #### try if the registrar has the address on the leg #### if, then set the outgoing leg and rewrite the packet to #### reflect the new URI my $packet = $entry->{packet}; my ($domain,$user,$sip_proto) = sip_uri2parts($packet->uri); DEBUG( 10,"query registrar for $sip_proto:$user\@$domain" ); if ( my @addr = $reg->query( "$sip_proto:$user\@$domain" )) { $packet->set_uri( $addr[0] ); } } # find out proxy on leg if (@$legs == 1 && ( my $addr = $self->{leg2proxy}{$legs->[0]} )) { $addr .= ':5060' if $addr !~m{:\d+$}; DEBUG( 50,"set addr to $addr from legs proxy address" ); @{ $entry->{dst_addr}} = $addr; } return $self->SUPER::__forward_request_getdaddr( $entry ); } Net-SIP-0.822/bin/nathelper.pl0000644000175100017510000000643512271423166014537 0ustar workwork############################################################################ # # Standalone nathelper which can be used with SIP proxy # for transferring RTP data between networks/through a firewall.. # uses Net::SIP::NAT::NATHelper::Server which communicates # with Net::SIP::NAT::NATHelper::Client # # Communication is via sock_stream sockets (unix domain or tcp) and the # commands are are an array-ref consisting of the command name # and the arguments. Commands are 'allocate','activate' and 'close'. # For the arguments of the command and the return values see the # methods in Net::SIP::NATHelper::Base. # For transport the requests and responses will be packet with # Storable::nfreeze and prefixed with a long in network format containing # the length of the freezed packet (necessary, because stream sockets # are used). # ############################################################################ use strict; use warnings; use Getopt::Long qw(:config posix_default bundling); use File::Path; use IO::Socket; use Net::SIP ':debug'; use Net::SIP::NATHelper::Server; ############################################################################ # USAGE ############################################################################ sub usage { print STDERR "ERROR: @_\n" if @_; print STDERR < \$debug, 'h|help' => sub { usage() }, 'R|chroot=s' => \$chroot, ) || usage( 'bad option' ); Net::SIP::Debug->level( $debug || 1 ) if defined $debug; my @sockets = @ARGV; @sockets or usage( "no command sockets" ); my @cfd; foreach my $socket ( @sockets ) { DEBUG( $socket ); if ( $socket =~ m{/} ) { if ( $socket =~m{/$} or -d $socket ) { -d $socket or mkpath( $socket, 0,0700 ) or die $!; $socket = $socket."/socket"; } push @cfd, IO::Socket::UNIX->new( Type => SOCK_STREAM, Local => $socket ) || die $!; } elsif ( $socket =~ m{^(.*):(\d+)$} ) { push @cfd, IO::Socket::INET->new( LocalAddr => $1, LocalPort => $2, Listen => 10, Reuse => 1, ) || die $!; } } # all sockets allocated, now we can change root if necessary if ( $chroot ) { # load Storable::* by eval if chroot eval { Storable::thaw() }; eval { Storable::nfreeze() }; chdir( $chroot ) || die $!; chroot( '.' ) || die $!; } # create wrapper and run Net::SIP::NATHelper::Server->new( @cfd )->loop; Net-SIP-0.822/Makefile.PL0000644000175100017510000000160213021277441013406 0ustar workworkuse ExtUtils::MakeMaker; use 5.010; $^O =~m{Win32}i and die "OS unsupported"; if (eval 'use Socket 1.95; 1' and ! eval 'Socket::inet_pton(Socket::AF_INET(),"0.0.0.0")') { warn "Socket::inet_pton failed on your system: $@"; exit(0); } WriteMakefile( NAME => 'Net::SIP', VERSION_FROM => 'lib/Net/SIP.pm', PREREQ_PM => { # 'Net::DNS' => 0.56, # optional # 'IO::Socket::SSL' => 1.956, # optional 'Socket' => 1.95, }, LICENSE => 'perl', $ExtUtils::MakeMaker::VERSION >= 6.46 ? ( 'META_MERGE' => { resources => { license => 'http://dev.perl.org/licenses/', repository => 'https://github.com/noxxi/p5-net-sip', homepage => 'https://github.com/noxxi/p5-net-sip', bugtracker => 'https://rt.cpan.org/Dist/Display.html?Queue=Net-SIP', }, }, ):(), ); Net-SIP-0.822/MANIFEST0000644000175100017510000000517213552315100012565 0ustar workworkCOPYRIGHT README MANIFEST Changes TODO BUGS INSTALL HOWTO THANKS Makefile.PL lib/Net/SIP.pm lib/Net/SIP.pod lib/Net/SIP/Debug.pm lib/Net/SIP/Debug.pod lib/Net/SIP/Packet.pm lib/Net/SIP/Packet.pod lib/Net/SIP/Request.pm lib/Net/SIP/Request.pod lib/Net/SIP/Response.pm lib/Net/SIP/Response.pod lib/Net/SIP/SDP.pm lib/Net/SIP/SDP.pod lib/Net/SIP/Leg.pm lib/Net/SIP/Leg.pod lib/Net/SIP/Dispatcher.pm lib/Net/SIP/Dispatcher.pod lib/Net/SIP/Dispatcher/Eventloop.pm lib/Net/SIP/Dispatcher/Eventloop.pod lib/Net/SIP/Util.pm lib/Net/SIP/Util.pod lib/Net/SIP/Endpoint.pm lib/Net/SIP/Endpoint.pod lib/Net/SIP/Endpoint/Context.pm lib/Net/SIP/Endpoint/Context.pod lib/Net/SIP/Redirect.pm lib/Net/SIP/Redirect.pod lib/Net/SIP/Registrar.pm lib/Net/SIP/Registrar.pod lib/Net/SIP/SocketPool.pm lib/Net/SIP/SocketPool.pod lib/Net/SIP/StatelessProxy.pm lib/Net/SIP/StatelessProxy.pod lib/Net/SIP/Blocker.pm lib/Net/SIP/Blocker.pod lib/Net/SIP/ReceiveChain.pm lib/Net/SIP/ReceiveChain.pod lib/Net/SIP/Authorize.pm lib/Net/SIP/Authorize.pod lib/Net/SIP/Simple.pm lib/Net/SIP/Simple.pod lib/Net/SIP/Simple/Call.pm lib/Net/SIP/Simple/Call.pod lib/Net/SIP/Simple/RTP.pm lib/Net/SIP/Simple/RTP.pod lib/Net/SIP/NATHelper/Base.pm lib/Net/SIP/NATHelper/Base.pod lib/Net/SIP/NATHelper/Local.pm lib/Net/SIP/NATHelper/Local.pod lib/Net/SIP/NATHelper/Client.pm lib/Net/SIP/NATHelper/Client.pod lib/Net/SIP/NATHelper/Server.pm lib/Net/SIP/NATHelper/Server.pod lib/Net/SIP/Dropper.pm lib/Net/SIP/Dropper/ByField.pm lib/Net/SIP/Dropper/ByIPPort.pm lib/Net/SIP/DTMF.pm lib/Net/SIP/DTMF.pod t/01_load.t t/02_listen_and_invite.t t/03_forward_stateless.t t/04_call_with_rtp.t t/05_call_with_stateless_proxy.t t/06_call_with_reinvite.t t/07_call_on_hold.t t/08_register_with_auth.t t/11_invite_timeout.t t/12_maddr.t t/13_maddr_proxy.t t/14_bugfix_0.51.t t/15_block_invite.t t/16_drop_invite.t t/17_call_with_reinvite_and_auth.t t/18_register_with_auth_step_by_step.t t/19_call_with_dtmf.t t/20_channel_on_hold.t t/21_channel_on_hold_stateless_proxy.t t/22_stateless_proxy_ack_on_error.t t/23_valid_message.t t/certs/caller.sip.test.pem t/certs/listen.sip.test.pem t/certs/proxy.sip.test.pem t/certs/ca.pem t/testlib.pl samples/README samples/invite_and_recv.pl samples/invite_and_send.pl samples/test_registrar_and_proxy.pl samples/register_and_redirect.pl samples/3pcc.pl samples/bench/README samples/bench/call.pl samples/bench/listen.pl samples/dtmf.pl bin/nathelper.pl bin/stateless_proxy.pl bin/answer_machine.pl bin/README tools/generate-dtmf.pl META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Net-SIP-0.822/THANKS0000644000175100017510000000113013142264510012340 0ustar workworkThanks to GeNUA mbh http://www.genua.de to let me work on this code and release it to the public. Thanks for bugreports, fixes, testing and other feedback from: richard[DOT]carver[AT]cloudmont[DOT]co[DOT]uk cpan:POLETTIX otherwiseguy Roland Mas Alex Revetski Gilad Novik gilad[AT]summit-tech[DOT]ca DetlefPilzecker[AT]web[DOT]de Net-SIP-0.822/README0000644000175100017510000000206212656712670012330 0ustar workworkThis is a module for handling SIP, the IETF standard for VOIP (RFC3261). It is written completely in perl. With the help of this module you can write SIP endpoints (e.g phones, answer machines), SIP proxies and registrars. It contains no GUI and no real code for working with video or audio, but has some support for RTP (no RTCP) and working with PCMU/8000 data, enough for sending PCMU/8000 encoded audio to a SIP peer and for receiving and saving PCMU/8000 audio data. The module is designed to be completely asynchronous, e.g. you either integrate it in your own event handling or you can use the simple event handling which is included. It was tested on Linux (Ubuntu 6.10,7.04,7.10), MacOSX 10.3+10.4, OpenBSD3.9+4.1 with various perl versions starting with perl5.8.7, including 5.10 Sample Code was tested with Snom 300 Phones, Asterisk 1.2, Fritz!Box and KPhone. See TODO for a list what still need to be done and BUGS for known bugs. See THANKS for contributors, bug reporters and sponsors. See samples/ for small examples. See bin/ for usable applications. Net-SIP-0.822/INSTALL0000644000175100017510000000057711136273030012472 0ustar workworkThis module can be installed on perl5.8 if you add Net::DNS. It was not tested on older versions but it might work if you add Storable, List::Util, Hash::Util, Time::HiRes, Digest::MD5 and IO::Socket. The module itself is pure perl, so if the prerequisites are fullfilled no C-Compiler is necessary. For installation do the usual perl Makefile.PL make make test make install Net-SIP-0.822/META.yml0000664000175100017510000000131513552315100012702 0ustar workwork--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-SIP no_index: directory: - t - inc requires: Socket: '1.95' resources: bugtracker: https://rt.cpan.org/Dist/Display.html?Queue=Net-SIP homepage: https://github.com/noxxi/p5-net-sip license: http://dev.perl.org/licenses/ repository: https://github.com/noxxi/p5-net-sip version: '0.822' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-SIP-0.822/META.json0000664000175100017510000000231513552315100013053 0ustar workwork{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-SIP", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Socket" : "1.95" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/Dist/Display.html?Queue=Net-SIP" }, "homepage" : "https://github.com/noxxi/p5-net-sip", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/noxxi/p5-net-sip" } }, "version" : "0.822", "x_serialization_backend" : "JSON::PP version 2.27400_02" }