############################################################################
# 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;
############################################################################
# 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
;
# alreday 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'
};
my
(
$leg
,
$dst_addr
) =
delete
@args
{
qw(leg dst_addr)
};
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
=>
$leg
,
dst_addr
=>
$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;