use
fields
qw( store max_expires min_expires dispatcher domains _last_timer )
;
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
;
}
sub
_store {
my
$self
=
shift
;
$self
->{store} =
shift
if
@_
;
return
$self
->{store};
}
sub
receive {
my
Net::SIP::Registrar
$self
=
shift
;
my
(
$packet
,
$leg
,
$addr
) =
@_
;
$packet
->is_request ||
return
;
if
(
$packet
->method ne
'REGISTER'
) {
my
$addr
= (sip_uri2parts(
$packet
->uri))[3];
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
;
}
my
$to
=
$packet
->get_header(
'to'
) or
do
{
DEBUG( 1,
"no to in register request. DROP"
);
return
;
};
(
$to
) = sip_hdrval2parts(
to
=>
$to
);
if
(
my
(
$domain
,
$user
,
$proto
) = sip_uri2parts(
$to
) ) {
$to
=
"$proto:$user\@$domain"
;
}
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'
);
my
@contact
=
$packet
->get_header(
'contact'
);
my
%curr
;
foreach
my
$c
(
@contact
) {
my
(
$c_addr
,
$param
) = sip_hdrval2parts(
contact
=>
$c
);
$c_addr
= $1
if
$c_addr
=~m{<(\w+:\S+)>};
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} ) {
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
;
$self
->expire();
DEBUG_DUMP( 100,
$self
->{store} );
my
$response
=
$packet
->create_response(
'200'
,
'OK'
);
while
(
my
(
$where
,
$expire
) =
each
%curr
) {
$expire
-=
$now
;
$response
->add_header(
contact
=>
"<$where>;expires=$expire"
);
}
$disp
->deliver(
$response
,
leg
=>
$leg
,
dst_addr
=>
$addr
);
return
200;
}
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
;
}
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
;
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;