Net-SIP-0.687/0000755000175100017520000000000012276436020011450 5ustar workworkNet-SIP-0.687/Changes0000644000175100017520000006547712276435433012775 0ustar workworkRevision history for Net::SIP 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 immediatly: - 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.687/COPYRIGHT0000644000175100017520000000031011136273030012727 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.687/THANKS0000644000175100017520000000105111404357366012367 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: cpan:POLETTIX otherwiseguy Roland Mas Alex Revetski Gilad Novik gilad[AT]summit-tech[DOT]ca DetlefPilzecker[AT]web[DOT]de Net-SIP-0.687/bin/0000755000175100017520000000000012276436020012220 5ustar workworkNet-SIP-0.687/bin/nathelper.pl0000644000175100017520000000643512271423166014551 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.687/bin/README0000644000175100017520000000107211136273030013072 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.687/bin/stateless_proxy.pl0000644000175100017520000003167012271424737016043 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.687/bin/answer_machine.pl0000644000175100017520000001303312271423166015542 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.687/Makefile.PL0000644000175100017520000000115712222213065013417 0ustar workworkuse ExtUtils::MakeMaker; require 5.008; $^O =~m{Win32}i and die "OS unsupported"; WriteMakefile( NAME => 'Net::SIP', VERSION_FROM => 'lib/Net/SIP.pm', PREREQ_PM => { 'Net::DNS' => 0.56, }, $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.687/README0000644000175100017520000000206611136273030012326 0ustar workworkThis is a module for handling SIP, the IETF standard for VOIP (RFC3261). It is written completly 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 is 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 completly 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.687/HOWTO0000644000175100017520000000371311136273030012271 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.687/samples/0000755000175100017520000000000012276436020013114 5ustar workworkNet-SIP-0.687/samples/test_registrar_and_proxy.pl0000644000175100017520000000127612271424737020612 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.687/samples/3pcc.pl0000644000175100017520000002331612271424737014315 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Getopt::Long qw(:config posix_default bundling); use Net::SIP ':all'; ############################################################## # # Implements 3pcc according to RFC 3725,4.1 'Flow I' # ############################################################## # Usage # ------------------------------------------------------------- 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.687/samples/README0000644000175100017520000000155011774636365014015 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.687/samples/dtmf.pl0000644000175100017520000000224012271424737014410 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.687/samples/bench/0000755000175100017520000000000012276436020014173 5ustar workworkNet-SIP-0.687/samples/bench/listen.pl0000644000175100017520000000221512271424737016035 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() }, '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.687/samples/register_and_redirect.pl0000644000175100017520000000153712271424737020015 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.687/samples/invite_and_recv.pl0000644000175100017520000001210512271424737016616 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.687/TODO0000644000175100017520000000062511404357340012142 0ustar workwork - 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 and make it truly asnychronous - 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 - implementation * full support for TCP Net-SIP-0.687/MANIFEST0000644000175100017520000000442312276436020012604 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/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/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 meta-data (added by MakeMaker) Net-SIP-0.687/lib/0000755000175100017520000000000012276436020012216 5ustar workworkNet-SIP-0.687/lib/Net/0000755000175100017520000000000012276436020012744 5ustar workworkNet-SIP-0.687/lib/Net/SIP.pod0000644000175100017520000001347712206354057014121 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 packets. Especially it provides the function B which is used for all callback unless otherwise in the documentation specified. 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 tghe source of L. =head2 SIP packet handling =over 4 =item L Is the base class for handling SIP packets and provides ways to parse, construct and manipulate SIP packets. =item L Is 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 Is 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 itself 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.687/lib/Net/SIP.pm0000644000175100017520000000413212276435457013752 0ustar workworkuse strict; use warnings; require 5.008; package Net::SIP; our $VERSION = '0.687'; # 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.687/lib/Net/SIP/0000755000175100017520000000000012276436020013377 5ustar workworkNet-SIP-0.687/lib/Net/SIP/Dispatcher.pm0000644000175100017520000007726212276111764016046 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 ); use Net::SIP::Leg; use Net::SIP::Util ':all'; use Errno qw(EHOSTUNREACH ETIMEDOUT ENOPROTOOPT EINVAL); use IO::Socket; use List::Util 'first'; use Net::DNS; use Carp 'croak'; use Net::SIP::Debug; use Scalar::Util 'weaken'; ########################################################################### # 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 [ prio,proto,ip,port ] like # in the DNS SRV record. # with special domain '*' a default can be specified, so that DNS # will not be used at all # Returns: $self ########################################################################### sub new { my ($class,$legs,$eventloop,%args) = @_; my ($outgoing_proxy,$do_retransmits,$domain2proxy) = delete @args{qw( outgoing_proxy do_retransmits domain2proxy )}; 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 ] } elsif ( m{^(?:(udp|tcp):)?([^:]+)(?::(\d+))?$} ) { my @proto = $1 ? ( $1 ) : ( 'udp','tcp' ); my $host = $2; my $port = $3 || 5060; $_ = [ map { [ -1, $_, $host, $port ] } @proto ]; } else { croak( "invalid entry in domain2proxy: $_" ); } } 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, ); $self->add_leg( @$legs ); if ( $outgoing_proxy ) { my $leg = $self->_find_leg4addr( $outgoing_proxy ) || die "cannot find leg for destination $outgoing_proxy"; $self->{outgoing_proxy} = $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; } ########################################################################### # 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 $fd = $leg->fd ) { my $cb = sub { # don't crash Dispatcher on bad or unexpected packets eval { my ($self,$leg) = @_; $self || return; # leg->receive might return undef if the packet wasnt # read successfully. for tcp connections the receive # on a listening socket might cause a new leg to be added # which then will receive the packet (maybe over multiple # read attempts) my ($packet,$from) = $leg->receive or do { DEBUG( 50,"failed to receive on leg" ); 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}); # FIXME: not IPv6 save my ($host,$port) = $d =~m{^\S+\s+(\S+?)(?::(\d+))?$}; my ($addr,$rport) = $from =~m{^(\S+)(?::(\d+))$}; my %nh; if ( exists $h->{rport} and ! defined $h->{rport}) { $nh{rport} = $rport; } if ( $host ne $addr or $nh{rport}) { # either hostname or different IP or required because # rport was set $nh{received} = $addr; } if (%nh) { $hdr->{value} = sip_parts2hdrval('via',$d,{ %$h,%nh}); $hdr->set_modified; } }, \( my $cvia )]); } # handle received packet $self->receive( $packet,$leg,$from ); }; if ($@) { DEBUG(1,"dispatcher croaked: $@"); } }; $cb = [ $cb,$self,$leg ]; weaken( $cb->[1] ); $self->{eventloop}->addFD( $fd, $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 $fd = $leg->fd ) { $self->{eventloop}->delFD( $fd ); } } } ########################################################################### # 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 # sock: leg must match sock # 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} }) { next if $args{addr} && $args{addr} ne $leg->{addr}; next if $args{port} && $args{port} != $leg->{port}; next if $args{proto} && $args{proto} ne $leg->{proto}; next if $args{sock} && $args{sock} != $leg->{sock}; next if $args{sub} && !invoke_callback( $args{sub},$leg ); push @rv,$leg } return @rv; } ########################################################################### # 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 [ip,port] or sockaddr, 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 (ip:port) # 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 ) { # completly 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}, ); } # 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 DEBUG( 50,"deliver through leg ".$leg->dump." \@$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). 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,undef,$param) = sip_uri2parts($uri); $domain or do { DEBUG( 50,"bad URI '$uri'" ); return invoke_callback($callback, EHOSTUNREACH ); }; my @proto; my $default_port = 5060; # XXXX hack, better would be to really parse URI, see *::Util::sip_hdrval2parts if ( $sip_proto eq 'sips' ) { $default_port = 5061; @proto = 'tcp'; } 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" ); 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; if ( $domain =~m{^(\d+\.\d+\.\d+\.\d+)(?::(\d+))?$} ) { # if domain part of URI is IPv4[:port] $default_port = $2 if defined $2; $ip_addr = $1; # e.g. 10.0.3.4 should match *.3.0.10.in-addr.arpa $domain = join( '.', reverse split( m{\.},$ip_addr )).'.in-addr.arpa'; } else { $domain =~s{\.*(?::(\d+))?$}{}; # remove trailing dots + port $default_port = $1 if defined $1; } 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 =~m{^[\d\.]+$} && eval { inet_aton($ip) }; } # entries in form [ prio,proto,ip,port ] my @resp; foreach my $addr ( @$dst_addr ) { if ( ref($addr)) { push @resp,$addr; # right format: see domain2proxy } else { $addr =~m{^(?:(udp|tcp):)?([^:]+)(?::(\d+))?$} || next; my $host = $2; my $proto = $1 ? [ $1 ] : \@proto; my $port = $3 ? $3 : $default_port; push @resp, map { [ -1,$_,$host,$port ] } @$proto; } } # should we use a fixed transport? if ( my $proto = $param->{transport} ) { @resp = grep { lc($_->[1]) eq lc($proto) } @resp; } my @param = ( $dst_addr,$legs,$allowed_legs,$default_port,$callback ); return __resolve_uri_final( @param,0,\@resp ) if @resp; # 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, $sip_proto, [ \&__resolve_uri_final, @param ] ); } sub __resolve_uri_final { my ($dst_addr,$legs,$allowed_legs,$default_port,$callback,$error,$resp) = @_; DEBUG_DUMP( 100,$resp ); return invoke_callback( $callback,EHOSTUNREACH ) unless $resp && @$resp; # for A records we got no port, use default_port $_->[3] ||= $default_port for(@$resp); # sort by prio # FIXME: can contradict order in @proto @$resp = sort { $a->[0] <=> $b->[0] } @$resp; @$dst_addr = (); @$legs = (); foreach my $r ( @$resp ) { my $leg = first { $_->can_deliver_to( proto => $r->[1], addr => $r->[2], port => $r->[3] )} @$allowed_legs; if ( $leg ) { push @$dst_addr, "$r->[1]:$r->[2]:$r->[3]"; push @$legs,$leg; } else { DEBUG( 50,"no leg for $r->[1]:$r->[2]:$r->[3]" ); } } return invoke_callback( $callback, EHOSTUNREACH ) if !@$dst_addr; invoke_callback( $callback ); } sub _find_leg4addr { my Net::SIP::Dispatcher $self = shift; my $dst_addr = shift; my ($proto,$ip) = $dst_addr =~m{^(?:(tcp|udp):)?([^:]+)}; my @legs; foreach my $leg (@{ $self->{legs} }) { push @legs,$leg if $leg->can_deliver_to( addr => $ip, proto => $proto ); } return @legs; } ########################################################################### # resolve hostname to IP using DNS # FIXME: should work asynchronously # Args: ($self,$host,$callback) # $host: hostname or hash with hostname as keys # $callback: gets called with (EINVAL) or (undef,result) once finished # result is IP for single hosts or the input hash ref where the # IPs are filled in as values # Returns: NONE ########################################################################### sub dns_host2ip { my Net::SIP::Dispatcher $self = shift; my ($host,$callback) = @_; if ( ref($host)) { my $err; foreach ( keys %$host ) { if ( my $addr = gethostbyname( $_ )) { $host->{$_} = inet_ntoa($addr); } else { $err = EINVAL; } } invoke_callback( $callback, $err,$host ); } else { my $addr = gethostbyname( $host ); invoke_callback( $callback, $addr ? ( undef,inet_ntoa($addr) ) : ( $? )); } } ########################################################################### # get SRV records using DNS # FIXME: should work asynchronously # Args: ($self,$domain,$proto,$sip_proto,$callback) # $domain: domain for SRV query # $proto: which protocols to check # $sip_proto: sip|sips # $callback: gets called with result once finished # result is \@list of [ prio,proto,name,port ] # Returns: NONE ########################################################################### sub dns_domain2srv { my Net::SIP::Dispatcher $self = shift; my ($domain,$protos,$sip_proto,$callback) = @_; # FIXME: don't do blocking DNS queries my $dns = Net::DNS::Resolver->new; # Try to get SRV records for _sip._udp.domain or _sip._tcp.domain my (@resp,%addr2ip); foreach my $proto ( @$protos ) { if ( my $q = $dns->query( '_'.$sip_proto.'._'.$proto.'.'.$domain,'SRV' )) { foreach my $rr ( $q->answer ) { if ( $rr->type eq 'A' ) { push @{ $addr2ip{$rr->name} }, $rr->address; } elsif ( $rr->type eq 'SRV' ) { push @resp,[ $rr->priority, $proto,$rr->target,$rr->port ] } } } } # name to addr based on additional records in DNS answer my @resp_resolved; for my $r (@resp) { if ( my $addr = $addr2ip{ $r->[2] } ) { for (@$addr) { my @cp = @$r; $cp[2] = $_; push @resp_resolved, \@cp; } } else { # either already IP or no additional data for resolving -> later my @cp = @$r; # XXX fixme blocking DNS lookup my $ipn = gethostbyname( $r->[2] ) or do { DEBUG( 1,"cannot resolve $r->[2]" ); next; }; $cp[2] = inet_ntoa($ipn); push @resp_resolved, \@cp; } } @resp = @resp_resolved; # if no SRV records try to resolve address directly unless (@resp) { # try addr directly my $default_port = $sip_proto eq 'sips' ? 5061:5060; if ( my $q = $dns->query( $domain,'A' )) { foreach my $rr ($q->answer ) { $rr->type eq 'A' || next; # XXX fixme, check that name in response corresponds to query # (beware of CNAMEs!) push @resp,map { [ -1, $_ , $rr->address,$default_port ] } @$protos; } } } my $error = @resp ? 0 : EINVAL; invoke_callback( $callback,$error,\@resp ); } ########################################################################### # 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 '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 'invoke_callback'; ########################################################################### # 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; if ( my $addr = $self->{dst_addr} ) { $self->{dst_addr} = [ $addr ] if !ref($addr) } if ( my $leg = $self->{leg} ) { $self->{leg} = [ $leg ] if UNIVERSAL::can( $leg,'deliver' ); } $self->{dst_addr} ||= []; $self->{leg} ||= []; # figure out retransmit times my $p = $self->{packet} || die "no packet for delivery"; if ( $p->is_response ) { unless ( $self->{leg} && $self->{dst_addr} ) { die "Response packet needs leg and dst_addr" } } 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; 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.687/lib/Net/SIP/SDP.pm0000644000175100017520000003471712271422677014407 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" Attribut. UNSUPPORTED!!!! ########################################################################### use strict; use warnings; package Net::SIP::SDP; use Hash::Util qw(lock_keys); use Net::SIP::Debug; 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}; $g{c} = "IN IP4 $g_addr" if $g_addr && !$g{c}; $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(); $o = "anonymous $t $t IN IP4 ".( $g_addr || '127.0.0.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} eq 'RTP/AVP' ? 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 ########################################################################### my $RX_IP4 = do { my $part = qr{2(?:[0-4]\d|5[0-5]|\d?)|[01]\d{0,2}|[3-9]\d?}; qr{^$part\.$part\.$part\.$part$} }; # very rough, just enough to distinguish IPv6 from hostnames my $RX_IP6 = qr{^[a-fA-F\d:]+:[a-fA-F\d:.]*$}; my $CHECK_IP6 = eval { require Socket6 } ? sub { Socket6::inet_pton( AF_INET6, shift ) } : sub { 1 }; # FIXME: better syntax check here? 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 $addr !~m{$RX_IP4}; } elsif ( $atyp eq 'IP6' ) { die "bad IP6 address: '$addr'" if $addr !~m{$RX_IP6} or !$CHECK_IP6->($addr); } else { die "addrtype $atyp not supported" } return $addr; } sub _join_c { my $addr = shift; my $atyp = $addr =~m{^[a-fA-F:\.]+$} ? '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 eq 'RTP/AVP'; # 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 eq 'RTP/AVP'; $port .= "/$range" if $range>1; return join( ' ',$media,$port,$proto,@fmt ); } 1; Net-SIP-0.687/lib/Net/SIP/NATHelper/0000755000175100017520000000000012276436020015161 5ustar workworkNet-SIP-0.687/lib/Net/SIP/NATHelper/Server.pm0000644000175100017520000001325412271422677017002 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.687/lib/Net/SIP/NATHelper/Server.pod0000644000175100017520000000500111136273030017121 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.687/lib/Net/SIP/NATHelper/Base.pm0000644000175100017520000010474412274227056016410 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; } # determine target for sock, e.g. original address my $addr_bin = inet_aton($addr); my @targets; for( my $i=0;$i<@socks;$i++ ) { my $dst = sockaddr_in( $port+$i,$addr_bin ); push @targets,$dst; } DEBUG( 100,"m_old=$addr $port/$range new_port=$new_port" ); push @new_media, [ $new_addr,$new_port,\@socks,\@targets ]; } $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 my $data = $self->{from}{$idfrom}; $data = $data && $data->{$cseq}; my $sess = $data && delete( $data->{sessions}{$idto} ) or do { DEBUG( 10,"tried to CANCEL non existing session in $self->{callid}|$cseq" ); return; }; push @info, $sess->info_as_hash( $self->{callid},$cseq ); DEBUG( 10,"close session {$sess->{id}} $self->{callid}|$cseq $idto,$idfrom success" ); } 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; foreach my $cseq ( keys %$by_cseq ) { my $sess = delete $by_cseq->{$cseq}{sessions}{$to} || next; push @info, $sess->info_as_hash( $self->{callid},$cseq ); DEBUG( 10,"close session {$sess->{id}} $self->{callid}|$cseq $idto,$idfrom " ); } } unless (@info) { DEBUG( 10,"tried to BYE non existing session in $self->{callid}" ); return; } DEBUG( 10,"close sessions $self->{callid} $idto,$idfrom 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,"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,"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,"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,"expired socketgroup $v->{id} because created($v->{created}) < unused($expire_unused)" ); $expired_sg{$v} = 1; } } elsif ( $lastmod < $expire_active ) { DEBUG( 10,"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 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]; 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 ]; 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 { my $bin = shift; use Socket; my ($port,$addr) = unpack_sockaddr_in( $bin ); return inet_ntoa($addr).':'.$port; }; 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.687/lib/Net/SIP/NATHelper/Base.pod0000644000175100017520000001530711332062323016536 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 transfered 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.687/lib/Net/SIP/NATHelper/Local.pm0000644000175100017520000000403612271422677016564 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 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,$callback ) } } # delete unused callbacks map { $loop->delFD( $_->[0] ) } values %old; } 1; Net-SIP-0.687/lib/Net/SIP/NATHelper/Client.pod0000644000175100017520000000213311136273030017074 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.687/lib/Net/SIP/NATHelper/Client.pm0000644000175100017520000000342212271422677016746 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 'invoke_callback'; 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 IO::Socket::INET->new( $socket ); } 1; Net-SIP-0.687/lib/Net/SIP/NATHelper/Local.pod0000644000175100017520000000251311136273030016712 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.687/lib/Net/SIP/Dropper/0000755000175100017520000000000012276436020015012 5ustar workworkNet-SIP-0.687/lib/Net/SIP/Dropper/ByField.pm0000644000175100017520000000464312271422677016705 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.687/lib/Net/SIP/Dropper/ByIPPort.pm0000644000175100017520000001356212271424737017036 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) = split(':',$from,2); # FIXME IPv4 only $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 4 =cut 1; Net-SIP-0.687/lib/Net/SIP/DTMF.pod0000644000175100017520000000516511774636365014664 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.687/lib/Net/SIP/DTMF.pm0000644000175100017520000003163312271424737014504 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{(\d)|([A-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; 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 $sub = $sub{$type} or return; my ($event,$duration,$media) = $sub->($payload,$time,$marker) 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 get 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.687/lib/Net/SIP/Dispatcher/0000755000175100017520000000000012276436020015465 5ustar workworkNet-SIP-0.687/lib/Net/SIP/Dispatcher/Eventloop.pod0000644000175100017520000000757111136273030020150 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, CALLBACK, ?NAME ) Adds file handle HANDLE to the event loop, so that CALLBACK gets triggered if HANDLE is readable. 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 ) Removes HANDLE from loop, e.g. no more checking for readability will be done. =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 resulution 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 occured (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.687/lib/Net/SIP/Dispatcher/Eventloop.pm0000644000175100017520000002015112271422677020005 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 timer now ); use Time::HiRes qw(gettimeofday); use Socket; use List::Util qw(first); use Net::SIP::Util 'invoke_callback'; use Net::SIP::Debug; use Errno 'EINTR'; ########################################################################### # creates new event loop # Args: $class # Returns: $self ########################################################################### sub new { my $class = shift; my $self = fields::new($class); %$self = ( fd => [], timer => [], now => scalar(gettimeofday()), ); return $self; } ########################################################################### # adds callback for the event, that FD is readable # Args: ($self,$fd,$callback,?$name) # $fd: file descriptor # $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,$callback,$name) = @_; defined( my $fn = fileno($fd)) || return; #DEBUG( 100, "$self added fn=$fn sock=".eval { my ($port,$addr) = unpack_sockaddr_in( getsockname($fd)); inet_ntoa($addr).':'.$port } ); $self->{fd}[$fn] = [ $fd,$callback,$name ]; } ########################################################################### # removes callback for readable for FD # Args: ($self,$fd) # $fd: file descriptor # Returns: NONE ########################################################################### sub delFD { my Net::SIP::Dispatcher::Eventloop $self = shift; my ($fd) = @_; defined( my $fn = fileno($fd)) || return; #DEBUG( 100, "$self delete fn=$fn sock=".eval { my ($port,$addr) = unpack_sockaddr_in( getsockname($fd)); inet_ntoa($addr).':'.$port } ); delete $self->{fd}[$fn]; } ########################################################################### # 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 $rin; if ( my @to_read = grep { $_ } @$fds ) { # Select which fds are readable or timeout my $rin = ''; map { vec( $rin,fileno($_->[0]),1 ) = 1 } @to_read; DEBUG( 100, "handles=".join( " ",map { fileno($_->[0]) } @to_read )); select( my $rout = $rin,undef,undef,$to ) < 0 and do { next if $! == EINTR; die $! }; # returned from select $looptime = $self->{now} = gettimeofday(); DEBUG( 100, "can_read=".join( " ",map { $_ } grep { $fds->[$_] && vec($rout,$_,1) } (0..$#$fds))); for( my $fn=0;$fn<@$fds;$fn++ ) { vec($rout,$fn,1) or next; my $fd_data = $fds->[$fn] or next; DEBUG( 50,"call cb on fn=$fn ".( $fd_data->[2] || '') ); invoke_callback( $fd_data->[1],$fd_data->[0] ); } } else { DEBUG( 50, "no handles, sleeping for %s", defined($to) ? $to : '' ); select(undef,undef,undef,$to ) } 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.687/lib/Net/SIP/Endpoint.pm0000644000175100017520000003150312271422677015527 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; # 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: where it should be registered # 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 => "sip:$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 ommitted 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 definitly successfully # delivered (tcp only) or an error occurred # Args: ($self,$ctx,$error,$delivery_packet) # $ctx: Net::SIP::Endpoint::Context # $error: errno if error occured # $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: ip:port 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: ip:port 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: ip:port 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.687/lib/Net/SIP/Request.pod0000644000175100017520000000525511400705701015533 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 overriden 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.687/lib/Net/SIP/Debug.pm0000644000175100017520000002066612271422677015005 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 ); our @EXPORT_OK = qw( debug stacktrace ); 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; } } } } else { # check if ( %level4package ) { # check if there is a specific level for this package my $pkg; for( my $i=1;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 { 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 { 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.687/lib/Net/SIP/StatelessProxy.pm0000644000175100017520000005304212276435073016761 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 ); use Net::SIP::Util ':all'; use Digest::MD5 qw(md5_hex md5); use Carp 'croak'; use List::Util 'first'; 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. # 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}; 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) = @_; if ( $contact =~m{\@} ) { # needs to be rewritten - incorporate leg_in:leg_out $contact = join("\|", (map { $_->key } ($leg_in,$leg_out)), $contact ); # add 'r' in front of hex so it does not look like phone number my $new = 'r'.unpack( 'H*',$crypt->($contact,1)); DEBUG( 100,"rewrite $contact -> $new" ); return $new; } if ( $contact =~m{^r([0-9a-f]+)$} ) { # needs to be written back my $old = $crypt->(pack("H*",$1),-1) or do { DEBUG(10,"no rewriting of $contact - bad encryption"); return; }; DEBUG(100,"rewrote back $contact -> $old"); (my $old_in,my $old_out,$old) = split( m{\|},$old,3); my $new_in = $leg_in->key; if ( $new_in ne $old_out ) { DEBUG(10,"no rewriting of $contact - went out through $old_out, came in through $new_in"); return; } if ( ref($leg_out) eq 'SCALAR' ) { # return the old_in as the new outgoing leg my @l = grep { $_->key eq $old_in } $disp->get_legs; if ( @l != 1 ) { DEBUG(10,"no rewriting of $contact - cannot find leg $old_in"); return; } $$leg_out = $l[0]; } elsif ( $leg_out ) { # check that it is the expected leg my $new_out = $leg_out->key; if ( $new_out ne $old_in ) { DEBUG(10,"no rewriting of $contact - went in through $old_in, should got out through $new_out"); return; } } DEBUG( 100,"rewrite back $contact -> $old" ); return $old; } # invalid format DEBUG( 100,"no rewriting of $contact" ); return; } { # RC4 with seed + checksum, picks random key on first use # dir: encrypt(1),decrypt(-1), otherwise symmetric w/o seed and checksum my @k; sub _stupid_crypt { my ($in,$dir) = @_; @k = map { rand(256) } (0..20) if ! @k; # create random key if ($dir>0) { $in = pack("N",rand(2**32)).$in; # add seed $in .= substr(md5($in),0,4); # add checksum } # RC4 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 ) { my $cksum = substr($out,-4,4,''); # remove checksum substr(md5($out),0,4) eq $cksum or return; # verify it substr($out,0,4,''); # remove seed } return $out; } } ########################################################################### # handle incoming requests # Args: ($self,$packet,$leg,$from) # $packet: Net::SIP::Request # $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 ); my ($addr,$port) = $first =~m{([\w\-\.]+)(?::(\d+))?\s*$}; $port ||= 5060; # FIXME default for sip, not sips! $addr = $param->{maddr} if $param->{maddr}; $addr = $param->{received} if $param->{received}; # where it came from $port = $param->{rport} if $param->{rport}; # where it came from @{ $entry->{dst_addr}} = ( "$addr:$port" ); DEBUG( 50,"get dst_addr from via header: $first -> $addr:$port" ); if ( $addr !~m{^[0-9\.]+$} ) { $self->{dispatcher}->dns_host2ip( $addr, [ \&__forward_response_1,$self,$entry ] ); } else { __forward_response_1($self,$entry); } } ########################################################################### # 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 ( @_ ) { my ($errno,$ip) = @_; unless ( $ip ) { DEBUG( 10,"cannot resolve address $entry->{dst_addr}[0]" ); return; } # replace host part in dst_addr with ip $entry->{dst_addr}[0] =~s{^(udp:|tcp:)?([^:]+)}{$1$ip}; } __forward_packet_final( $self,$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 ($addr,$port) = $data =~m{([\w\-\.]+)(?::(\d+))?\s*$}; $port ||= 5060; # FIXME sips my @legs = $self->{dispatcher}->get_legs(addr => $addr, port => $port); 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 $route = $route[0] =~m{<([^\s>]+)>} && $1 || $route[0]; my ($data,$param) = sip_hdrval2parts( route => $route ); my ($addr,$port) = $data =~m{([\w\-\.]+)(?::(\d+))?\s*$}; $port ||= 5060; # FIXME sips $entry->{nexthop} = $param->{maddr} ? "$param->{maddr}:$port" : "$addr:$port"; DEBUG( 50, "setting nexthop from route $route 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}}; my $proto = $entry->{incoming_leg}{proto} eq 'tcp' ? [ 'tcp','udp' ]:undef; $entry->{nexthop} ||= $entry->{packet}->uri, DEBUG( 50,"need to resolve $entry->{nexthop} proto=".( $proto ||'') ); return $self->{dispatcher}->resolve_uri( $entry->{nexthop}, $entry->{dst_addr}, $entry->{outgoing_leg}, [ \&__forward_request_1,$self,$entry ], $proto, ); } ########################################################################### # 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; 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) { my ($addr) = m{^(?:udp:|tcp:)?([^:]+)}; $hostnames{$addr} = undef if $addr !~m{^[0-9\.]+$}; } if ( %hostnames ) { $self->{dispatcher}->dns_host2ip( \%hostnames, [ \&__forward_request_2,$self,$entry ] ); } else { __forward_packet_final($self,$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 { !m{^(?:\w*:)?\Q$host\E(?::)?} } @$dst_addr; next; } else { DEBUG( 50,"resolved $host -> $ip" ); s{^(\w*:)?\Q$host\E(:)?}{$1$ip$2} for (@$dst_addr); } } return unless @$dst_addr; # nothing could be resolved __forward_packet_final( $self,$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); $addr .= '@'.$outgoing_leg->{addr}.':'.$outgoing_leg->{port}; 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->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 : ''; # 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; } # 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); if ( my $from = $packet->get_header( 'from' ) ) { my ($data,$param) = sip_hdrval2parts( from => $from ); my $tag = $param->{tag} || ''; $idfrom = "$data\0$tag"; } else { return [ 0,'no FROM header in packet' ] } if ( my $to = $packet->get_header( 'to' ) ) { my ($data,$param) = sip_hdrval2parts( from => $to ); my $tag = $param->{tag} || ''; $idto = "$data\0$tag"; } else { return [ 0,'no TO 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 = join( ':', @{ $incoming_leg }{qw(addr port)} ); my $oleg = join( ':', @{ $outgoing_leg }{qw(addr port)} ); 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; # 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 ); my $new_media = $nathelper->allocate_sockets( $callid,$cseq,$idfrom,$idto,$side,$outgoing_leg->{addr}, 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 ( ! $nathelper->activate_session( $callid,$cseq,$idfrom,$idto ) ) { if ( $method eq 'ACK' ) { DEBUG( 50,"session $callid|$cseq $idfrom -> $idto still incomplete in ACK" ); return [ 0,'incomplete session in ACK' ] } else { # 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.687/lib/Net/SIP/Response.pm0000644000175100017520000000232712271422677015547 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.687/lib/Net/SIP/Leg.pm0000644000175100017520000004326412276427655014473 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 qw( sip_hdrval2parts invoke_callback sip_uri_eq ); use Net::SIP::Packet; use Net::SIP::Request; use Net::SIP::Response; use Errno 'EHOSTUNREACH'; use fields qw( sock addr port proto contact branch via ); # sock: the socket for the leg # addr,port: addr,port where it listens # 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 # sock: socket, the addr,port and proto will be determined from this # addr,port,proto: if sock is not given they will be used to # create a socket. port defaults to 5060 and proto to udp # if port is defined and 0 a port will be assigned from the system # proto: defaults to udp # contact: default based on addr and port # branch: if not given will be created # Returns: $self ########################################################################### sub new { my ($class,%args) = @_; my $self = fields::new($class); if ( my $addr = delete $args{addr} ) { my $port = delete $args{port}; # port = 0 -> get port from system if ( ! defined $port ) { $port = $1 if $addr =~s{:(\d+)$}{}; $port ||= 5060; } my $proto = $self->{proto} = delete $args{proto} || 'udp'; if ( ! ( $self->{sock} = delete $args{sock} ) ) { $self->{sock} = IO::Socket::INET->new( Proto => $proto, LocalPort => $port, LocalAddr => $addr, ) || die "failed $proto $addr:$port $!"; } if ( ! $port ) { # get the assigned port ($port) = unpack_sockaddr_in( getsockname( $self->{sock} )); } $self->{port} = $port; $self->{addr} = $addr; } elsif ( my $sock = $self->{sock} = delete $args{sock} ) { # get data from socket ($self->{port}, my $addr) = unpack_sockaddr_in( $sock->sockname ); $self->{addr} = inet_ntoa( $addr ); $self->{proto} = ( $sock->socktype == SOCK_STREAM ) ? 'tcp':'udp' } my ($port,$sip_proto) = $self->{port} == 5060 ? ( '','sip' ) : ( $self->{port} == 5061 and $self->{proto} eq 'tcp' ) ? ( '','sips' ) : ( ":$self->{port}",'sip' ) ; my $leg_addr = $self->{addr}.$port; $self->{contact} = delete $args{contact} || "$sip_proto:$leg_addr"; $self->{branch} = 'z9hG4bK'. ( delete $args{branch} || md5_hex( @{$self}{qw( addr port proto )} )); $self->{contact} =~m{^\w+:(.*)}; $self->{via} = sprintf( "SIP/2.0/%s %s;branch=", uc($self->{proto}),$leg_addr ); return $self; } ########################################################################### # 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 ); 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,$addr;$callback) # $packet: Net::SIP::Packet # $addr: ip:port where to deliver # $callback: optional callback, if an error occured the callback will # be called with $! as argument. If no error occured and the # proto is tcp the callback will be called with error=0 to show # that the packet was definitly delivered (and need not retried) ########################################################################### sub deliver { my Net::SIP::Leg $self = shift; my ($packet,$addr,$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+:}; $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 => '' ); } my ($proto,$host,$port) = $addr =~m{^(?:(\w+):)?([\w\-\.]+)(?::(\d+))?$}; #DEBUG( "%s -> %s %s %s",$addr,$proto||'',$host, $port||'' ); $port ||= $proto eq 'sips' ? 5061: 5060; $self->sendto( $packet->as_string, $host,$port,$callback ) || return; DEBUG( 2, "delivery from $self->{addr}:$self->{port} to $addr OK:\n%s", $packet->dump( Net::SIP::Debug->level -2 ) ); } ########################################################################### # send data to peer # Args: ($self,$data,$host,$port,$callback) # $data: string representation of SIP packet # $host: target ip # $port: target port # $callback: callback for error|success, see method deliver # Returns: $success # $success: true if no problems occured while sending (this does not # mean that the packet was delivered reliable!) ########################################################################### sub sendto { my Net::SIP::Leg $self = shift; my ($data,$host,$port,$callback) = @_; # XXXXX for now udp only # for tcp the delivery might be done over multiple callbacks # (eg whenever I can write on the socket) # for tcp I need to handle the case where I got a request on # the leg, then the leg got closed and the I've need to deliver # the response over a new leg, created based on the master leg # eg I still need to know which outgoing master leg I have, # even if my real outgoing leg is closed (responsed might be # delivered over the same tcp connection, but no need to do so) if ( $self->{proto} ne 'udp' ) { use Errno 'EINVAL'; DEBUG( 1,"can only proto udp for now, but not $self->{proto}" ); invoke_callback( $callback, EINVAL ); } my $host4 = inet_aton( $host ) or do { # this should not happen because host should better be IP DEBUG( 1, "lookup problems of $host?" ); invoke_callback( $callback, EINVAL ); return; }; my $target = sockaddr_in( $port,$host4 ); unless ( $self->{sock}->send( $data,0,$target )) { DEBUG( 1,"send failed: callback=$callback error=$!" ); invoke_callback( $callback, $! ); return; } # XXXX dont forget to call callback back with error=0 if # delivery by tcp successful return 1; } ########################################################################### # receive packet # for udp socket it just makes a recv on the socket and returns the packet # for tcp master sockets it makes accept and creates a new leg based on # the masters leg. # Args: ($self) # Returns: ($packet,$from) || () # $packet: Net::SIP::Packet # $from: ip:port where it got packet from ########################################################################### sub receive { my Net::SIP::Leg $self = shift; if ( $self->{proto} ne 'udp' ) { DEBUG( 1,"only udp is supported at the moment" ); return; } my $from = recv( $self->{sock}, my $buf, 2**16, 0 ) or do { DEBUG( 1,"recv failed: $!" ); 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; } my $packet = eval { Net::SIP::Packet->new( $buf ) } or do { DEBUG( 3,"cannot parse buf as SIP: $@\n$buf" ); return; }; my ($port,$host) = unpack_sockaddr_in( $from ); $host = inet_ntoa($host); DEBUG( 2,"received on $self->{addr}:$self->{port} from $host:$port packet\n%s", $packet->dump( Net::SIP::Debug->level -2 )); return ($packet,"$host:$port"); } ########################################################################### # 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; $val .= substr( md5_hex( ( sort $packet->get_header( 'proxy-authorization' )), ( sort $packet->get_header( 'proxy-require' )), $packet->get_header( 'route' ), $packet->get_header( 'to' ), $packet->get_header( 'from' ), ($packet->get_header( 'via' ))[0] || '', ($packet->as_parts())[1], ),0,15 ) if $level>2; 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 { my $spec = shift; my ($proto,$addr) = $spec =~m{^(?:(udp|tcp):)?([^:]+)} or return; # wrong spec? $spec{proto} = $proto if $proto; $spec{addr} = $addr; # ignore port } # check against proto of leg return if ( $spec{proto} && $spec{proto} ne $self->{proto} ); # 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 } ########################################################################### # returns FD on Leg # Args: $self # Returns: socket of leg ########################################################################### sub fd { my Net::SIP::Leg $self = shift; return $self->{sock}; } ########################################################################### # some info about the Leg for debugging # Args: $self # Returns: string ########################################################################### sub dump { my Net::SIP::Leg $self = shift; return ref($self)." $self->{proto}:$self->{addr}:$self->{port}"; } ########################################################################### # returns key for leg # Args: $self # Returns: key (string) ########################################################################### sub key { my Net::SIP::Leg $self = shift; return "$self->{proto}:$self->{addr}:$self->{port}"; } 1; Net-SIP-0.687/lib/Net/SIP/Registrar.pm0000644000175100017520000001502112271422677015706 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_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; # 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.687/lib/Net/SIP/Request.pm0000644000175100017520000002530412271422677015401 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}; $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.687/lib/Net/SIP/Util.pod0000644000175100017520000001241411332062323015013 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 create_socket_to ( ADDR, [ PROTO ] ) Creates socket with protocol PROTO (default 'udp') on a local interface, from where ADDR is reachable. This is done by first creating a UDP socket with target ADDR and using getsockname(2) to find out the local address of this socket. The newly created socket than will be bound to this 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 abbrevation). 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 ) 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 domain part (including ports if any) =item user - The user part of the SIP address =item proto - The protocol, e.g. "sip" or "sips". =item data - The part before any parameter, includes SIP address =item param - A hash reference to any parameter, like in B. =back =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). =back Net-SIP-0.687/lib/Net/SIP/Endpoint.pod0000644000175100017520000001622011743215045015664 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 => '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 C<< "ip:port" >> of the sender of the request. =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 C<< "ip:port" >> of registrar. Mandatory. =item from The adress 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 C<< "ip:port" >> of the sender. 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 (C<< "ip:port" >>) 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.687/lib/Net/SIP/Simple/0000755000175100017520000000000012276436020014630 5ustar workworkNet-SIP-0.687/lib/Net/SIP/Simple/RTP.pm0000644000175100017520000003301712271424737015646 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); use Socket; use Net::SIP::Debug; use Net::SIP::DTMF; # 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;1;$i++ ) { my $sock = $lsocks->[$i] || last; $sock = $sock->[0] if UNIVERSAL::isa( $sock,'ARRAY' ); my $s_sock = $ssocks->[$i] || last; $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 $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 ) or last; #DEBUG( "$didit=$$didit" ); $$didit = 1; 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; last if ! $remote; # call on hold ? 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, [ $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;1;$i++ ) { my $sock = $lsocks->[$i] || last; $sock = $sock->[0] if UNIVERSAL::isa( $sock,'ARRAY' ); my $s_sock = $ssocks->[$i] || last; $s_sock = $s_sock->[0] if UNIVERSAL::isa( $s_sock,'ARRAY' ); my $addr = $raddr->[$i]; $addr = $addr->[0] if ref($addr); # recv once I get an event on RTP socket my $receive = sub { my ($writeto,$targs,$didit,$sock) = @_; while (1) { my $buf = _receive_rtp( $sock,$writeto,$targs,$didit ); defined($buf) or return; CAN_NONBLOCKING or return; } }; $call->{loop}->addFD( $sock, [ $receive, $writeto, { dtmf_gen => $args->{dtmf_events}, dtmf_xtract => $mdtmf && $mdtmf->[$i] && $args->{cb_dtmf} && [ $mdtmf->[$i], $args->{cb_dtmf} ], }, \$didit ], 'rtp_receive' ); my $reset_to_blocking = CAN_NONBLOCKING && $sock->blocking(0); # sending need to be done with a timer # ! $addr == call on hold if ( $addr ) { my $cb_done = $args->{cb_rtp_done} || sub { shift->bye }; my $timer = $call->{dispatcher}->add_timer( 0, # start immediatly [ \&_send_rtp,$s_sock,$call->{loop},$addr,$readfrom, { 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) = @_; $call->{loop}->delFD( $sock ); $sock->blocking(1) if $rb; $timer->cancel(); }, $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) # $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 # Return: $packet # $packet: received RTP packet (including header) ########################################################################### sub _receive_rtp { my ($sock,$writeto,$targs,$didit) = @_; 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) { use Socket; my ($lport,$laddr) = unpack_sockaddr_in( getsockname($sock)); $laddr = inet_ntoa( $laddr ).":$lport"; my ($pport,$paddr) = unpack_sockaddr_in( $from ); $paddr = inet_ntoa( $paddr ).":$pport"; DEBUG( "got data on socket %d %s from %s",fileno($sock),$laddr,$paddr ); } $$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,"payload=$seq/%d xh=%d padding=%d cc=%d", length($payload),$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 ); } 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 # $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,$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); 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) { my ($fp,$fa) = unpack_sockaddr_in( getsockname($sock) ); $fa = inet_ntoa($fa); my ($tp,$ta) = unpack_sockaddr_in( $addr ); $ta = inet_ntoa($ta); DEBUG( 50, "$fa:$fp -> $ta:$tp seq=$seq ts=%x",$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 ) || die $!; } ########################################################################### # 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.687/lib/Net/SIP/Simple/Call.pod0000644000175100017520000003056311774762014016225 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 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] >>. =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 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. =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 accessable 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.687/lib/Net/SIP/Simple/RTP.pod0000644000175100017520000000453711136273030016004 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 echos 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 immediatly but with an 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 immediatly. 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 argument. If no traffic comes in for more then 10 seconds it will hang up the call because of inactivity. =back Net-SIP-0.687/lib/Net/SIP/Simple/Call.pm0000644000175100017520000005760512271424737016065 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 # 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,240,0.03,'iLBC/8000' ] ########################################################################### use Net::SIP::Util qw(create_rtp_sockets invoke_callback); 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: 5*160 bytes/second $param->{dtmf_events} ||= []; # get added by sub dtmf 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 = $self->{ctx} ) { $self->{endpoint}->close_context( $ctx ); } $self->{param} = {}; $self->SUPER::cleanup; } 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 immediatly ########################################################################### 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 == 487 ) { # request was canceled, probably be me -> ignore } else { $self->error( "Failed with error $errno".( $code ? " code=$code" :"" ) ); } 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 => 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 occured # $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 occured: $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; invoke_callback($param->{cb_invite},$self,$packet); # send 200 OK with sdp body my $response = $packet->create_response( '200','OK',{},$param->{sdp} ); DEBUG( 100,'created response '.$response->as_string ); $self->{endpoint}->new_response( $ctx,$response,$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; my $null_address = pack( 'CCCC',0,0,0,0 ); # c=0.0.0.0 => call on hold for( my $i=0;$i<@media;$i++) { my $m = $media[$i]; my $range = $m->{range} || 1; my $paddr = inet_aton( $m->{addr} ); if ( $paddr eq $null_address ) { # on-hold for this media push @$raddr, undef; } else { my @socks = map { scalar(sockaddr_in( $m->{port}+$_ , $paddr )) } (0..$range-1); push @$raddr, @socks == 1 ? $socks[0] : \@socks; if ( $m->{media} eq 'audio' and $param->{cb_dtmf} ) { my %rmap = ( 'PCMU/8000' => 'audio_type', 'telephone-event/8000' => 'rfc2833_type' ); my %pargs = ( audio_type => 0 ); # 0 is default type for PCMU/8000 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}{addr}; if ( !$sdp ) { # create SDP body my $raddr = $param->{media_rsocks}; # if no raddr yet just assume one my @media; 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; } if ( $m->{media} eq 'audio' ) { # enforce PCMU/8000 for now $m = { %$m, fmt => '0' } } push @media, { media => $m->{media}, proto => $m->{proto}, range => $m->{range}, fmt => [ $m->{fmt},101 ], a => [ "rtpmap:101 telephone-event/8000", "fmtp:101 0-16" ], }; } } else { my $rp = $param->{rtp_param}; 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, IO::Socket::INET->new(@arg) || die $!; } } else { $socks = IO::Socket::INET->new(@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.687/lib/Net/SIP/SDP.pod0000644000175100017520000000764711774636365014567 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 specifiy 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.687/lib/Net/SIP/Debug.pod0000644000175100017520000001056311332062323015127 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 ommited (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 selectivly 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 to STDERR debugging info. 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 callers package, the callers 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 Net-SIP-0.687/lib/Net/SIP/Util.pm0000644000175100017520000002426612271422677014674 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 IO::Socket; use Net::SIP::Debug; use Carp qw(confess croak); use base 'Exporter'; our @EXPORT_OK = qw( sip_hdrval2parts sip_parts2hdrval sip_uri2parts create_socket_to create_rtp_sockets invoke_callback sip_uri_eq ); our %EXPORT_TAGS = ( all => \@EXPORT_OK ); 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 ########################################################################### sub sip_hdrval2parts { croak( "usage: sip_hdrval2parts( key => val )" ) if @_!=2; my ($key,$v) = @_; return if !defined($v); my $delim = ';'; if ( $key eq 'www-authenticate' || $key eq 'proxy-authenticate' || $key eq 'authorization' || $key eq 'proxy-authorization' ) { # these keys have ',' instead of ';' as delimiter $delim = ','; } # 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 = ';'; if ( $key eq 'www-authenticate' || $key eq 'proxy-authenticate' || $key eq 'authorization' || $key eq 'proxy-authorization' ) { # these keys have ',' instead of ';' as delimiter $delim = ','; } 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) }sg; $v = '"'.$v.'"' if $v =~m{\s|$delim}; $val .= '='.$v } } return $val; } ########################################################################### # extract parts from SIP URI # Args: $uri # Returns: $domain || ($domain,$user,$proto,$data,$param) # $domain: SIP domain maybe with port # $user: user part # $proto: 'sip'|'sips' # $data: full part before any params # $param: hashref with params, e.g { transport => 'udp',... } ########################################################################### sub sip_uri2parts { my $uri = shift; $uri = $1 if $uri =~m{<([^>]+)>\s*$}i; my ($data,$param) = sip_hdrval2parts( uri => $uri ); if ( $data =~m{^(?:(sips?):)?(?:([^\s\@]*)\@)?([\w\-\.:]+)}i ) { my ($proto,$user,$domain) = ($1,$2,$3); $proto ||= 'sip'; return wantarray ? ($domain,$user,lc($proto),$data,$param) : $domain } else { return; } } ########################################################################### # 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; } ########################################################################### # 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: tcp|udp, 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 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 = do { $dst_addr =~s{:.*}{}; # in case ip:port was given my $sock = IO::Socket::INET->new( PeerAddr => $dst_addr, PeerPort => 5060, Proto => 'udp' ) || return; # No route? my $x = getsockname($sock) or return; my (undef,$addr) = unpack_sockaddr_in( $x ); inet_ntoa( $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 my ($sock,$port); for my $p ( 5060,5062..5100 ) { DEBUG( "try to listen on $laddr:$p" ); $sock = IO::Socket::INET->new( LocalAddr => $laddr, LocalPort => $p, Proto => $proto, ); if ( $sock ) { $port = $p; last } } if ( ! $sock ) { $sock = IO::Socket::INET->new( LocalAddr => $laddr, # use any port Proto => $proto, ) || return; $port = (unpack_sockaddr_in( getsockname($sock)))[0]; } DEBUG( "listen on $laddr:$port" ); return wantarray ? ($sock,"$laddr:$port" ) : $sock; } ########################################################################### # 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); while ( $tries-- >0 ) { last if @socks == $range; map { close($_) } @socks; @socks = (); $port = 2*int(rand($diff2)) + $min; for( my $i=0;$i<$range;$i++ ) { push @socks, IO::Socket::INET->new( 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"; } } 1; Net-SIP-0.687/lib/Net/SIP/Registrar.pod0000644000175100017520000000504311427715356016060 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 wil 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.687/lib/Net/SIP/Endpoint/0000755000175100017520000000000012276436020015157 5ustar workworkNet-SIP-0.687/lib/Net/SIP/Endpoint/Context.pm0000644000175100017520000004615212271424737017160 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 $rsp40x = delete $args{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) = sip_hdrval2parts( to => $self->{remote_contact}||$to); # 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}, ); 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 occured # 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: ip:port 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, dst_addr => $from ); } # 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 ); } 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 INVIE, 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, dst_addr => $from ); } 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.687/lib/Net/SIP/Endpoint/Context.pod0000644000175100017520000002204111743213606017307 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 occured ( 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 (Authorization required) or 407 (Proxy Authorization 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 choice) or 301 (moved permanently) it will invoke the callback because it cannot resolve the issue automatically. But if it's 302 (moved temporally) 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.687/lib/Net/SIP/Blocker.pm0000644000175100017520000000423012271422677015325 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.687/lib/Net/SIP/Dropper.pm0000644000175100017520000000543212271422677015364 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.687/lib/Net/SIP/ReceiveChain.pod0000644000175100017520000000437411332062323016431 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.687/lib/Net/SIP/Authorize.pm0000644000175100017520000002376512271422677015734 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.687/lib/Net/SIP/Packet.pm0000644000175100017520000006400712276430025015152 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 text header lines body as_string ); # code: response code (numeric) or request method # 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 was only one argument it will interprete # it as a string representation (see new_from_string), otherwise it will # assume a hash/array representation (see new_from_parts) # Args: see new_from_string|new_from_parts # Returns: $self ########################################################################### sub new { my $class = shift; return @_>1 ? $class->new_from_parts(@_) : $class->new_from_string(@_); } ########################################################################### # create new object from parts # Args: ($class,$code,$text,$header,$body) # $code: 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: # if $class is Net::SIP::Packet $self will be either Net::SIP::Request # or Net::SIP::Response (both are subclasses from Net::SIP::Packet) depending # if it is a request or response ########################################################################### 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; } if ( $code =~m{^\d} ) { # Response $class = 'Net::SIP::Response' if $class eq 'Net::SIP::Packet'; } else { # Request $code = uc($code); # uppercase method $class = 'Net::SIP::Request' if $class eq 'Net::SIP::Packet'; } my $self = fields::new($class); $self->{code} = $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 ); if ( $class eq 'Net::SIP::Packet' ) { $class = $data->{code} =~m{^\d} ? 'Net::SIP::Response' :'Net::SIP::Request'; } my $self = fields::new($class); %$self = %$data; return $self; } ########################################################################### # Find out if it is a request # Args: $self # Returns: 1 if it's a request ########################################################################### sub is_request { my $self = shift; $self->{code} || $self->as_parts(); return $self->{code} !~m{^\d} } ########################################################################### # Find out if it is a response # Args: $self # Returns: 1 if it's a response ########################################################################### sub is_response { return ! shift->is_request() } ########################################################################### # 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 = _normalize_hdrkey(shift) if @_>1; 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 immediatly 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->{code} =~m{^\d} ? "SIP/2.0 $self->{code} $self->{text}\r\n" # Response : "$self->{code} $self->{text} SIP/2.0\r\n" # Request ; $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 ) { my ($code,$text,$header,$body) = $self->as_parts; if ( $self->is_request ) { return "REQ $code $text ".( $body ? 'with body' :'' ); } else { return "RESP $code '$text' ".( $body ? 'with body' :'' ); } } else { return $self->as_string } } ########################################################################### # Return parts # Args: ($self) # Returns: ($code,$text,$header,$body) # $code: 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 immediatly# if ( ! $self->{code} ) { my $data = _string2parts( $self->{as_string} ); %$self = ( %$self,%$data ); } return @{$self}{qw(code text header body)} if $self->{code}; } { 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, 'call-id' => sub { $_[0] =~ $callid_rx or die "invalid callid, should be 'word [@ word]'"; return $_[0]; }, 'cseq' => sub { $_[0] =~ m{^\d+\s+\w+\s*$} or die "invalid cseq, should be 'number method'"; return $_[0]; }, ); sub _hdrkey_parse_keep { return $_[0] }; sub _hdrkey_parse_num { my ($v,$k) = @_; $v =~m{^(\d+)\s*$} || die "invalid $k, should be number"; 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 = ''; } } } 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 ); 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; } elsif ( $header[0] =~m{^(\w+)\s+(\S.*?)\s+SIP/2\.0\s*$} ) { # Request, e.g. INVITE SIP/2.0 $result{code} = $1; $result{text} = $2; } else { die "bad request: starts with '$header[0]'"; } shift(@header); $result{body} = $body; my @hdr; my @lines; while (@header) { my ($k,$v) = $header[0] =~m{^([^\s:]+)\s*:\s*(.*)} or die "bad header line $header[0]"; 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_comma_seperated($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) ); } push @lines, [ $line, int(@v) ]; } $result{header} = \@hdr; $result{lines} = \@lines; 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, header... # done by setting code 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->{code} = undef if $self->{as_string}; } ########################################################################### # Trigger updating string # done by setting as_string as undef if code 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->{code}; } ########################################################################### # 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: orginal key # $value: value # $line: index of header line in orginal 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.687/lib/Net/SIP/Redirect.pod0000644000175100017520000000247311400716236015650 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 manging 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.687/lib/Net/SIP/Simple.pod0000644000175100017520000002060511743214215015335 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 anncouncement once connected $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 ommitted (including the colon) and defaults to 'udp' and C can be ommitted 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. =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. =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.687/lib/Net/SIP/Dispatcher.pod0000644000175100017520000002101511416525702016171 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. If no leg but an outgoing proxy is specified a leg will be created which can reach the outgoing proxy by udp. =item do_retransmits If TRUE retransmits will be done accoring 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. =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 sock Matches if the given L is used as the socket in the leg. =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 specifiy subseconds. WHEN can be C<0> to trigger the timer immediatly. 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 speciffy 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 C<< "ip:port" >> where to deliver the packet. This is necessary for responses, for requests it can be find 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 occured 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.687/lib/Net/SIP/Packet.pod0000644000175100017520000001307711625642135015325 0ustar workwork =head1 NAME Net::SIP::Packet - handling of SIP packets =head1 SYNOPSIS use Net::SIP::Packet; 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 ) This is the default constructor. Depending on the number of arguments branches into B or B. =item new_from_string ( STRING ) Interprets STRING as a SIP request or response and creates L or L object accordingly. 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. 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. =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 wich 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.687/lib/Net/SIP/Response.pod0000644000175100017520000000123411332062323015672 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 orginal request by parsing the CSeq header. =back Net-SIP-0.687/lib/Net/SIP/Blocker.pod0000644000175100017520000000166411423326607015475 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.687/lib/Net/SIP/Leg.pod0000644000175100017520000001020111731167365014614 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::INET object. C, C and C will be determined from this object and not from %ARGS. =item addr The local 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 port The port of the socket. Defaults to 5060. =item proto The connection protocol, e.g. 'tcp' or 'udp'. Defaults to 'udp'. =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. =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 creeate 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, which is C<< "ip:port" >>. 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 Reads a packet from the socket and returns the L PACKET and the senders ADDR as C<< "ip:port" >>. If reading failed will return C<()>. =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 hostname which can be prefixed by the protocol ( e.g. C ) and postfixed by the port ( C, C,... ). If the caller has 'proto','addr' and 'port' already as seperate 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 fd Returns socket of leg. In some special environments (like tests) there might be legs, which don't have a socket associated. In this case you need to call B from L yourself, because it cannot be called automatically once it receives data on the socket. =item dump Returns string containing information about the leg. Used for debugging. =back Net-SIP-0.687/lib/Net/SIP/Redirect.pm0000644000175100017520000000310712271422677015507 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_uri2parts($packet->uri))[3]; 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.687/lib/Net/SIP/Authorize.pod0000644000175100017520000000772511433431735016072 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.687/lib/Net/SIP/Simple.pm0000644000175100017520000004550012271424737015201 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 (addr:port) '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 of # the form (proto:)?host(:port)? where proto defaults to udp and # port defaults to 5060. # 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 $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 " 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 ( m{^(?:(udp|tcp):)?([\w\-\.]+)(?::(\d+))?$} ) { # host|udp:host|udp:host:port|host:port $_ = Net::SIP::Leg->new( addr => $2, port => $3, proto => $1 ); } } my $ob = delete $args{outgoing_proxy} || delete $args{proxy}; if ( $ob && ! first { $_->can_deliver_to($ob) } @$legs ) { my ($sock) = create_socket_to( $ob ) or die $!; push @$legs, Net::SIP::Leg->new( sock => $sock ); } if ( $registrar && ! first { $_->can_deliver_to($registrar) } @$legs ) { my ($sock) = create_socket_to( $registrar ) or die $!; push @$legs, Net::SIP::Leg->new( sock => $sock ); } 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( 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" ); 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->{addr}.':'.$leg->{port}; $contact.= '@'.$local unless $contact =~s{\@([\w\-\.:]+)}{\@$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 {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; Net-SIP-0.687/lib/Net/SIP/StatelessProxy.pod0000644000175100017520000000772112276435271017132 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 should rewrite it and if one puts something without '@' it should try to rewrite it back (and return B<()> if it cannot rewrite it back). A working default implementation is provided. If you want to implement your own: the callbacks gets the arguments B, 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. =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. If not defined, then RC4 will be used with a (pseudo)random key, 4 byte (pseudo)random seed and 4 byte "checksum" (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.687/lib/Net/SIP/ReceiveChain.pm0000644000175100017520000000463112271422677016276 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.687/t/0000755000175100017520000000000012276436020011713 5ustar workworkNet-SIP-0.687/t/13_maddr_proxy.t0000644000175100017520000000313212271424737014741 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, addr => '10.0.105.10', port => '5062' ); 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 ($data,$host,$port,$callback) = @_; ok( "$host:$port" eq "172.25.2.1:7070", "got target from maddr" ); } Net-SIP-0.687/t/08_register_with_auth.t0000644000175100017520000000677612271424737016336 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Digest::MD5 'md5_hex'; my ($csock,$caddr) = create_socket(); my ($ssock,$saddr) = create_socket(); # 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( leg => $lsock, from => 'sip:me@example.com', ); print "Started\n"; my $realm = ''; $ua->register( registrar => $peer, auth => sub { $realm = shift; return [ 'wolf','lobo' ], }, ) || die; print "Registered wolf ($realm)\n"; $realm = ''; $ua->register( registrar => $peer, auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; print "Registered 007 ($realm)\n"; $realm = ''; $ua->register( from => 'sip:noauth@example.com', registrar => $peer, auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; 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 => $lsock ); 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.687/t/17_call_with_reinvite_and_auth.t0000644000175100017520000000431712271424737020141 0ustar workwork#!/usr/bin/perl use strict; use warnings; use Test::More tests => 11; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my ($csock,$caddr) = create_socket(); my ($ssock,$saddr) = create_socket(); # 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 = Simple->new( leg => $lsock, from => "sip:me\@$laddr", auth => [ 'me','secret' ], ); print "Started\n"; my $call = $ua->invite( "sip: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 ); print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( leg => $lsock, from => "sip:me\@$laddr", ); # 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 ); print "Received BYE\n" if $bye; } Net-SIP-0.687/t/03_forward_stateless.t0000644000175100017520000000733212271424737016151 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 ); 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 { $_[0] =~m{^(?:(udp|tcp):)?([^:]+)(?::(\d+))$} } }; 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.687/t/testlib.pl0000644000175100017520000001712412271423305013720 0ustar workworkuse strict; use warnings; use IO::Socket; ############################################################################ # # 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"; }; *{'like'} = sub { my ( $data,$rx,$desc ) = @_; ok( $data =~ $rx ? 1:0, $desc ); }; } $SIG{ __DIE__ } = sub { ok( 0,"@_" ); killall(); exit(1); }; ############################################################################ # 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; #diag( "killed @pids with $sig" ); while ( wait() >= 0 ) {} # collect all @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 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 ); #diag( "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 ) { #diag( "found" ); return wantarray ? ( $1,$name ) : $1; } } # if not found try to read new data $timeout = $end - time() if $end; return @bad if $timeout < 0; 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 ) { #diag( "$name >CLOSED<" ); delete $fd2buf{$fd}; @fd = grep { $_ != $fd } @fd; close($fd); next; } diag( "$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/%d", @{$m}{qw( media addr port range )}; } } else { $dump .= "NO SDP"; } print $dump."\n"; } ############################################################################ # create isocket on IP # return socket and ip:port ############################################################################ sub create_socket { my ($addr,$port,$proto) = @_; $addr ||= '127.0.0.1'; $proto ||= 'udp'; $port ||= 0; my $sock = IO::Socket::INET->new( Proto => $proto, $proto eq 'tcp' ? ( Listen => 10 ):(), LocalAddr => $addr, LocalPort => $port, ) || die $!; ($port,$addr) = unpack_sockaddr_in( getsockname($sock) ); return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock; } ############################################################################ # 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 'invoke_callback'; 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 $addr = shift; $addr =~m{^(?:(udp|tcp):)?([\w\.-]+)(?::(\d+))?$} || die $addr; return { proto => $1, addr => $2, port => $3 } } 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,$to ); return $self->SUPER::deliver( $packet,$to,$callback ); } 1; Net-SIP-0.687/t/14_bugfix_0.51.t0000644000175100017520000000660712271424737014353 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->{leg}, 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 ); 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->{leg}, 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 ); print "BYE done\n" if $bye_ok; } Net-SIP-0.687/t/15_block_invite.t0000644000175100017520000000534112271424737015067 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 ) { 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"; } } ############################################### # 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.687/t/12_maddr.t0000644000175100017520000000533612271424737013507 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; use Net::SIP::Util ':all'; use IO::Socket; # 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 = $sock_uas->sockhost.':'.$sock_uas->sockport; # 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 ) { 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( $uas_addr,$read ); ok( <$read>, "UAS finished" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', leg => scalar(create_socket_to( $peer )), ); ok( $uac, 'UAC created' ); ok( <$pipe>, "UAS ready\n" ); # wait until UAS is ready my $ringing = 0; my ($peer_addr,$peer_port) = split( ':',$peer ); my $call = $uac->invite( "", ); my $stop; if ( $call ) { ok( $call, 'Call established' ); $call->loop(1); $call->bye( cb_final => \$stop ); $call->loop( \$stop,10 ); } ok( $stop, 'UAS down' ); } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => $sock ) || 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 ); # done if ( $call_closed ) { print $pipe "UAS finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } } Net-SIP-0.687/t/06_call_with_reinvite.t0000644000175100017520000001145112271424737016271 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my ($csock,$caddr) = create_socket(); my ($ssock,$saddr) = create_socket(); # 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( leg => $lsock, from => "sip:me\@$laddr", ); 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( "sip:me\@$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 ); print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( leg => $lsock, from => "sip:me\@$laddr", ); # 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); } 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.687/t/19_call_with_dtmf.t0000644000175100017520000000775212271423305015401 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use IO::Socket; use File::Temp; # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket(); 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 close($from_uas); $to_uac->autoflush; uas( $sock_uas, $to_uac ); exit(0); } # PARENT = UAC close($sock_uas); close($to_uac); alarm(40); $SIG{__DIE__} = $SIG{ALRM} = sub { kill 9,$pid; ok( 0,'died' ) }; uac( $uas_addr,$from_uas ); my $uas = <$from_uas>; is( $uas, "UAS finished events=1 2 D # 3 4 B *\n", "UAS finished with DTMF" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer_addr,$from_uas) = @_; Debug->set_prefix( "DEBUG(uac):" ); my $packets = 300; 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 ($lsock,$laddr) = create_socket_to( $peer_addr ); diag( "UAC on $laddr" ); my $uac = Simple->new( from => 'me.uac@example.com', leg => $lsock, domain2proxy => { 'example.com' => $peer_addr }, ); 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( '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'); $call->dtmf('34B*',methods => 'audio'); $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' ); $uas = <$from_uas>; is( $uas,"UAS RTP ok\n","UAS RTP ok" ); # DTMF echoed back is( "@events","1 2 D # 3 4 B *", "UAC DTMF received"); } ############################################### # UAS ############################################### sub uas { my ($sock,$to_uac) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $uas = Simple->new( domain => 'example.com', leg => $sock ) || 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,@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 10 seconds $uas->loop( \$call_closed, 10 ); diag( "received ".int(@received)."/100 packets events=@events" ); # at least 20% of all RTP packets should come through if ( @received > 20 ) { print $to_uac "UAS RTP ok\n" } else { print $to_uac "UAS RTP received only ".int(@received)."/100 packets\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.687/t/05_call_with_stateless_proxy.t0000644000175100017520000001557712271423305017716 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; 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 ($luac,$luas,@lproxy); for ( $luac,$luas,$lproxy[0],$lproxy[1] ) { my ($sock,$addr) = create_socket(); $_ = { sock => $sock, addr => $addr }; } diag( "UAS on $luas->{addr} " ); diag( "UAC on $luac->{addr} " ); diag( "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} ) :(), ); } # socket for nathelper server my $nath_sock = IO::Socket::INET->new( Listen => 10, LocalAddr => '127.0.0.1', # use any port ) || die $!; my $nath_addr = do { my ($p,$a) = unpack_sockaddr_in( $nath_sock->sockname ); inet_ntoa($a).':'.$p }; 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->{addr},$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]{addr} ); 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/UDP $lproxy[1]{addr};}i,1,$uas ); fd_grep_ok( qr{\Qvia: SIP/2.0/UDP $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_addr,$natcb) = @_; # need loop seperatly 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_addr }, ); $proxy->create_stateless_proxy( nathelper => $nathelper ); print "ready\n"; $proxy->loop; } # -------------------------------------------------------------- # UAC # -------------------------------------------------------------- sub uac { my ($lsock,$proxy) = @_; 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, ) || 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 ); 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 ); 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.687/t/18_register_with_auth_step_by_step.t0000644000175100017520000000767612271424737021117 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use Digest::MD5 'md5_hex'; my ($csock,$caddr) = create_socket(); my ($ssock,$saddr) = create_socket(); # 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( leg => $lsock, from => 'sip:me@example.com', ); print "Started\n"; # first registration w/o auth my $resp40x; $ua->register( registrar => $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 => $peer, auth => sub { $realm = shift; return [ 'wolf','lobo' ], }, resp40x => $resp40x, ) || die; print "Registered wolf ($realm)\n"; $realm = ''; $ua->register( registrar => $peer, auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; print "Registered 007 ($realm)\n"; $realm = ''; $ua->register( from => 'sip:noauth@example.com', registrar => $peer, auth => sub { $realm = shift; return [ '007','secret' ], }, ) || die; 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 => $lsock ); 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.687/t/07_call_on_hold.t0000644000175100017520000001202712271424737015034 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; my ($csock,$caddr) = create_socket(); my ($ssock,$saddr) = create_socket(); # 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( leg => $lsock, from => "sip:me\@$laddr", ); 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( "sip:me\@$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 ); print "BYE done\n" if $bye_ok; } ############################################################################# # UAS ############################################################################# sub uas { my ($lsock,$laddr,$peer) = @_; my $ua = Simple->new( leg => $lsock, from => "sip:me\@$laddr", ); # 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); } 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.687/t/16_drop_invite.t0000644000175100017520000000714612271424737014747 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 ) { 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-port into tempfile print $tfh $uac->{dispatcher}{legs}[0]{port}; # FIXME access interna close($tfh); $call->loop(\$dropping, 5); # done ok( ! $dropping,'UAC got no answer from UAS' ); } ############################################### # 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' => '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 $uac_port = <$tfh>; 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.687/t/01_load.t0000644000175100017520000000055712271423305013323 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.687/t/02_listen_and_invite.t0000644000175100017520000000631012271424737016106 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; use Net::SIP; use Net::SIP::Util ':all'; use IO::Socket; # 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 ) { 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( $uas_addr,$read ); ok( <$read>, "UAS finished" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer_addr,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', leg => scalar(create_socket_to( $peer_addr )), domain2proxy => { 'example.com' => $peer_addr }, ); 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' ); } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => $sock ) || 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 ); # done if ( $call_closed ) { print $pipe "UAS finished\n"; } else { print $pipe "call closed by timeout not stopvar\n"; } } Net-SIP-0.687/t/11_invite_timeout.t0000644000175100017520000000635112271424737015461 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; use Net::SIP; use Net::SIP::Util ':all'; use IO::Socket; # 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 ) { 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( $uas_addr,$read ); ok( <$read>, "done" ); wait; ############################################### # UAC ############################################### sub uac { my ($peer_addr,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uac):" ); ok( <$pipe>, "UAS created\n" ); # wait until UAS is ready my $uac = Net::SIP::Simple->new( from => 'me.uac@example.com', leg => scalar(create_socket_to( $peer_addr )), domain2proxy => { 'example.com' => $peer_addr }, ); 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)'); } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Net::SIP::Debug->set_prefix( "DEBUG(uas):" ); my $uas = Net::SIP::Simple->new( domain => 'example.com', leg => $sock ) || 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 ); print $pipe "UAS done\n"; } Net-SIP-0.687/t/04_call_with_rtp.t0000644000175100017520000000677612271423305015253 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; do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; use Net::SIP ':all'; use IO::Socket; use File::Temp; # create leg for UAS on dynamic port my ($sock_uas,$uas_addr) = create_socket(); diag( "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 close($read); $write->autoflush; uas( $sock_uas, $write ); exit(0); } # PARENT = UAC close( $sock_uas ); close($write); alarm(15); $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):" ); 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 ($lsock,$laddr) = create_socket_to( $peer_addr ); diag( "UAC on $laddr" ); my $uac = Simple->new( from => 'me.uac@example.com', leg => $lsock, domain2proxy => { 'example.com' => $peer_addr }, ); 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" ); } ############################################### # UAS ############################################### sub uas { my ($sock,$pipe) = @_; Debug->set_prefix( "DEBUG(uas):" ); my $uas = Simple->new( domain => 'example.com', leg => $sock ) || 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 { diag( 'call created' );1 }, cb_established => sub { diag( 'call established' ) }, cb_cleanup => sub { diag( '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 ); diag( "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.687/tools/0000755000175100017520000000000012276436020012610 5ustar workworkNet-SIP-0.687/tools/generate-dtmf.pl0000644000175100017520000000512212271424737015676 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.687/META.yml0000644000175100017520000000131612276436020012722 0ustar workwork--- #YAML:1.0 name: Net-SIP version: 0.687 abstract: ~ author: [] license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Net::DNS: 0.56 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 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Net-SIP-0.687/INSTALL0000644000175100017520000000057711136273030012504 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.687/BUGS0000644000175100017520000000010411136273030012120 0ustar workwork* TCP support not fully implemented * SIPS support not implemented