File Coverage

blib/lib/Net/SIP/Registrar.pm
Criterion Covered Total %
statement 21 118 17.8
branch 0 48 0.0
condition 0 24 0.0
subroutine 7 13 53.8
pod 4 4 100.0
total 32 207 15.4


line stmt bran cond sub pod time code
1             ###########################################################################
2             # package Net::SIP::Registrar
3             # implements a simple Registrar
4             # FIXME: store registry information in a more flat format, so that
5             # user can give a tied hash for permanent storage. Or give an object
6             # interface with a simple default implementation but a way for the
7             # user to provide its own implementation
8             ###########################################################################
9              
10 43     43   240 use strict;
  43         77  
  43         1127  
11 43     43   178 use warnings;
  43         69  
  43         1323  
12              
13             package Net::SIP::Registrar;
14 43     43   204 use fields qw( store max_expires min_expires dispatcher domains _last_timer );
  43         74  
  43         190  
15 43     43   3302 use Net::SIP::Util ':all';
  43         80  
  43         7163  
16 43     43   332 use Carp 'croak';
  43         71  
  43         1890  
17 43     43   214 use Net::SIP::Debug;
  43         66  
  43         232  
18 43     43   251 use List::Util 'first';
  43         78  
  43         45833  
19              
20             ###########################################################################
21             # creates new registrar
22             # Args: ($class,%args)
23             # %args
24             # max_expires: maximum time for expire, default 300
25             # min_expires: manimum time for expire, default 30
26             # dispatcher: Net::SIP::Dispatcher object
27             # domains: domain or \@list of domains the registrar is responsable
28             # for, if not given it cares about everything
29             # domain: like domains if only one domain is given
30             # Returns: $self
31             ###########################################################################
32             sub new {
33 0     0 1   my $class = shift;
34 0           my %args = @_;
35 0   0       my $domains = delete $args{domains} || delete $args{domain};
36 0 0 0       $domains = [ $domains ] if $domains && !ref($domains);
37              
38 0           my $self = fields::new($class);
39 0           %$self = %args;
40 0   0       $self->{max_expires} ||= 300;
41 0   0       $self->{min_expires} ||= 30;
42 0 0         $self->{dispatcher} or croak( "no dispatcher given" );
43 0           $self->{store} = {};
44 0           $self->{domains} = $domains;
45 0           return $self;
46             }
47              
48             # hack to have access to the store, to dump or restore it
49             sub _store {
50 0     0     my $self = shift;
51 0 0         $self->{store} = shift if @_;
52 0           return $self->{store};
53             }
54              
55             ###########################################################################
56             # handle packet, called from Net::SIP::Dispatcher on incoming requests
57             # Args: ($self,$packet,$leg,$addr)
58             # $packet: Net::SIP::Request
59             # $leg: Net::SIP::Leg where request came in (and response gets send out)
60             # $addr: ip:port where request came from and response will be send
61             # Returns: $code
62             # $code: response code used in response (usually 200, but can be 423
63             # if expires was too small). If not given no response was created
64             # and packet was ignored
65             ###########################################################################
66             sub receive {
67 0     0 1   my Net::SIP::Registrar $self = shift;
68 0           my ($packet,$leg,$addr) = @_;
69              
70             # accept only REGISTER
71 0 0         $packet->is_request || return;
72 0 0         if ( $packet->method ne 'REGISTER' ) {
73             # if we know the target rewrite the destination URI
74 0           my $addr = sip_parts2uri((sip_uri2parts($packet->uri))[0,1,2]);
75 0           DEBUG( 1,"method ".$packet->method." addr=<$addr>" );
76 0           my @found = $self->query( $addr );
77 0 0         @found or do {
78 0           DEBUG( 1, "$addr not locally registered" );
79 0           return;
80             };
81 0           DEBUG( 1,"rewrite URI $addr in ".$packet->method." to $found[0]" );
82 0           $packet->set_uri( $found[0] );
83 0           return; # propagate to next in chain
84             }
85              
86 0 0         my $to = $packet->get_header( 'to' ) or do {
87 0           DEBUG( 1,"no to in register request. DROP" );
88 0           return;
89             };
90              
91             # what address will be registered
92 0           ($to) = sip_hdrval2parts( to => $to );
93 0 0         if ( my ($domain,$user,$proto) = sip_uri2parts( $to ) ) {
94             # normalize if possible
95 0           $to = "$proto:$user\@$domain";
96             }
97              
98             # check if domain is allowed
99 0 0         if ( my $rd = $self->{domains} ) {
100 0           my ($domain) = $to =~m{\@([\w\-\.]+)};
101 0 0   0     if ( ! first { $domain =~m{\.?\Q$_\E$}i || $_ eq '*' } @$rd ) {
  0 0          
102 0           DEBUG( 1, "$domain matches none of my own domains. DROP" );
103 0           return;
104             }
105             }
106              
107 0           my $disp = $self->{dispatcher};
108 0           my $loop = $disp->{eventloop};
109 0           my $now = int($loop->looptime);
110 0           my $glob_expire = $packet->get_header( 'expires' );
111              
112             # to which contacs it will be registered
113 0           my @contact = $packet->get_header( 'contact' );
114              
115 0           my %curr;
116 0           foreach my $c (@contact) {
117             # update contact info
118 0           my ($c_addr,$param) = sip_hdrval2parts( contact => $c );
119 0 0         $c_addr = $1 if $c_addr =~m{<(\w+:\S+)>}; # do we really need this?
120 0           my $expire = $param->{expires};
121 0 0         $expire = $glob_expire if ! defined $expire;
122             $expire = $self->{max_expires}
123 0 0 0       if ! defined $expire || $expire > $self->{max_expires};
124 0 0         if ( $expire ) {
125 0 0         if ( $expire < $self->{min_expires} ) {
126             # expire to small
127 0           my $response = $packet->create_response(
128             '423','Interval too brief',
129             );
130 0           $disp->deliver( $response, leg => $leg, dst_addr => $addr );
131 0           return 423;
132             }
133 0 0         $expire += $now if $expire;
134             }
135 0           $curr{$c_addr} = $expire;
136             }
137              
138 0           $self->{store}{ $to } = \%curr;
139              
140             # expire now!
141 0           $self->expire();
142 0           DEBUG_DUMP( 100,$self->{store} );
143              
144             # send back a list of current contacts
145 0           my $response = $packet->create_response( '200','OK' );
146 0           while ( my ($where,$expire) = each %curr ) {
147 0           $expire -= $now;
148 0           $response->add_header( contact => "<$where>;expires=$expire" );
149             }
150              
151             # send back where it came from
152 0           $disp->deliver( $response, leg => $leg, dst_addr => $addr );
153 0           return 200;
154             }
155              
156             ###########################################################################
157             # return information for SIP address
158             # Args: ($self,$addr)
159             # Returns: @sip_contacts
160             ###########################################################################
161             sub query {
162 0     0 1   my Net::SIP::Registrar $self = shift;
163 0           my $addr = shift;
164 0           DEBUG( 50,"lookup of $addr" );
165 0   0       my $contacts = $self->{store}{$addr} || return;
166 0           return grep { m{^sips?:} } keys %$contacts;
  0            
167             }
168              
169             ###########################################################################
170             # remove all expired entries from store
171             # Args: $self
172             # Returns: none
173             ###########################################################################
174             sub expire {
175 0     0 1   my Net::SIP::Registrar $self = shift;
176              
177 0           my $disp = $self->{dispatcher};
178 0           my $loop = $disp->{eventloop};
179 0           my $now = $loop->looptime;
180              
181 0           my $store = $self->{store};
182 0           my (@drop_addr,$next_exp);
183 0           while ( my ($addr,$contact) = each %$store ) {
184 0           my @drop_where;
185 0           while ( my ($where,$expire) = each %$contact ) {
186 0 0         if ( $expire<$now ) {
187 0           push @drop_where, $where;
188             } else {
189 0 0 0       $next_exp = $expire if ! $next_exp || $expire < $next_exp;
190             }
191             }
192 0 0         if ( @drop_where ) {
193 0           delete @{$contact}{ @drop_where };
  0            
194 0 0         push @drop_addr,$addr if !%$contact;
195             }
196             }
197 0 0         delete @{$store}{ @drop_addr } if @drop_addr;
  0            
198              
199             # add timer for next expire
200 0 0         if ( $next_exp ) {
201 0           my $last_timer = \$self->{_last_timer};
202 0 0 0       if ( ! $$last_timer || $next_exp < $last_timer || $$last_timer <= $now ) {
      0        
203 0           $disp->add_timer( $next_exp, [ \&expire, $self ] );
204 0           $$last_timer = $next_exp;
205             }
206             }
207             }
208              
209             1;