######################################################################### # 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) # outgoing_proxy - specify outgoing proxy, will create leg if necessary # proxy - alias to outgoing_proxy # route|routes - \@list with SIP routes in right syntax "<sip:host:port;lr>"... # 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 $from = delete $args{from}; my $contact = delete $args{contact}; my $domain = delete $args{domain}; if ($from) { $domain = $1 if !defined($domain) && $from =~m{\bsips?:[^@]+\@([\w\-\.]+)}; $from = "$from <sip:$from\@$domain>" if $from !~m{\s} && $from !~m{\@}; } 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 $legs = delete $args{legs} || delete $args{leg}; $legs = [ $legs ] if $legs && ref($legs) ne 'ARRAY'; $legs ||= []; foreach ($legs ? @$legs : ()) { if ( UNIVERSAL::isa( $_, 'Net::SIP::Leg' )) { # keep } elsif ( UNIVERSAL::isa( $_, 'IO::Handle' )) { # socket $_ = Net::SIP::Leg->new( sock => $_ ) } elsif ( UNIVERSAL::isa( $_, 'HASH' )) { # create leg from hash $_ = Net::SIP::Leg->new( %$_ ) } elsif (my ($proto,$host,$port,$family) = sip_uri2sockinfo($_)) { $_ = Net::SIP::Leg->new(proto => $proto, addr => $host, port => $port, family => $family); } else { die "invalid leg specification: $_"; } } my $ob = delete $args{outgoing_proxy} || delete $args{proxy}; for my $dst ($registrar, $ob) { $_ or next; first { $_->can_deliver_to($dst) } @$legs and next; my ($proto,$addr,$port,$family) = sip_uri2sockinfo($dst); push @$legs, Net::SIP::Leg->new( proto => $proto, dst => [ $addr, $port, $family ], ); } my $loop = delete $args{loop} || Net::SIP::Dispatcher::Eventloop->new; my $d2p = delete $args{domain2proxy} || delete $args{d2p}; my $disp; if ( $disp = delete $args{dispatcher} ) { $disp->add_leg( @$legs ); } else { $disp = Net::SIP::Dispatcher->new( $legs, $loop, outgoing_proxy => $ob, domain2proxy => $d2p, ); } 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}; %$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 ommitted # @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(1); $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}; $to = "$to <sip:$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 = @_; # 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 ( my $cbc = $args->{cb_create} ) { my $cbx =invoke_callback( $cbc, $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 } } if ( my $ccb = $args->{cb_cleanup} ) { push @{ $call->{call_cleanup}}, $ccb; } # 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;