File Coverage

blib/lib/Net/SIP/Request.pm
Criterion Covered Total %
statement 93 112 83.0
branch 25 44 56.8
condition 8 21 38.1
subroutine 16 17 94.1
pod 10 10 100.0
total 152 204 74.5


line stmt bran cond sub pod time code
1             ###########################################################################
2             # package Net::SIP::Request
3             # subclass from Net::SIP::Packet for managing the request packets
4             # has methods for creating ACK, CANCEL based on the request (and response)
5             # and for adding Digest authorization (md5+qop=auth only) to the
6             # request based on the requirements in the response
7             ###########################################################################
8              
9 44     44   683 use strict;
  44         83  
  44         1199  
10 44     44   195 use warnings;
  44         59  
  44         1792  
11              
12             package Net::SIP::Request;
13 44     44   211 use base 'Net::SIP::Packet';
  44         69  
  44         7391  
14 44     44   303 use Net::SIP::Debug;
  44         101  
  44         308  
15 44     44   262 use Net::SIP::Util 'invoke_callback';
  44         156  
  44         2079  
16              
17 44     44   231 use Digest::MD5 'md5_hex';
  44         80  
  44         43107  
18              
19             my %ResponseCode = (
20             # Informational
21             100 => 'Trying',
22             180 => 'Ringing',
23             181 => 'Call Is Being Forwarded',
24             182 => 'Queued',
25             183 => 'Session Progress',
26              
27             # Success
28             200 => 'OK',
29              
30             # Redirection
31             300 => 'Multiple Choices',
32             301 => 'Moved Permanently',
33             302 => 'Moved Temporarily',
34             305 => 'Use Proxy',
35             380 => 'Alternative Service',
36              
37             # Client-Error
38             400 => 'Bad Request',
39             401 => 'Unauthorized',
40             402 => 'Payment Required',
41             403 => 'Forbidden',
42             404 => 'Not Found',
43             405 => 'Method Not Allowed',
44             406 => 'Not Acceptable',
45             407 => 'Proxy Authentication Required',
46             408 => 'Request Timeout',
47             410 => 'Gone',
48             413 => 'Request Entity Too Large',
49             414 => 'Request-URI Too Large',
50             415 => 'Unsupported Media Type',
51             416 => 'Unsupported URI Scheme',
52             420 => 'Bad Extension',
53             421 => 'Extension Required',
54             423 => 'Interval Too Brief',
55             480 => 'Temporarily not available',
56             481 => 'Call Leg/Transaction Does Not Exist',
57             482 => 'Loop Detected',
58             483 => 'Too Many Hops',
59             484 => 'Address Incomplete',
60             485 => 'Ambiguous',
61             486 => 'Busy Here',
62             487 => 'Request Terminated',
63             488 => 'Not Acceptable Here',
64             491 => 'Request Pending',
65             493 => 'Undecipherable',
66              
67             # Server-Error
68             500 => 'Internal Server Error',
69             501 => 'Not Implemented',
70             502 => 'Bad Gateway',
71             503 => 'Service Unavailable',
72             504 => 'Server Time-out',
73             505 => 'SIP Version not supported',
74             513 => 'Message Too Large',
75              
76             # Global-Failure
77             600 => 'Busy Everywhere',
78             603 => 'Decline',
79             604 => 'Does not exist anywhere',
80             606 => 'Not Acceptable',
81             );
82              
83             ###########################################################################
84             # Redefine methods from Net::SIP::Packet, no need to find out dynamically
85             ###########################################################################
86 530     530 1 1526 sub is_request {1}
87 334     334 1 1616 sub is_response {0}
88              
89             ###########################################################################
90             # Accessors for method and URI
91             ###########################################################################
92 755     755 1 2151 sub method { return (shift->as_parts())[0] }
93 184     184 1 497 sub uri { return (shift->as_parts())[1] }
94              
95             sub set_uri {
96 30     30 1 71 my Net::SIP::Request $self = shift;
97 30         146 $self->_update_string;
98 30         84 $self->{text} = shift;
99             }
100              
101             ###########################################################################
102             # set cseq
103             # Args: ($self,$number)
104             # $number: new cseq number
105             # Returns: $self
106             ###########################################################################
107             sub set_cseq {
108 0     0 1 0 my Net::SIP::Request $self = shift;
109 0         0 my $cseq = shift;
110 0         0 $self->set_header( cseq => "$cseq ".$self->method );
111 0         0 return $self;
112             }
113              
114             ###########################################################################
115             # create ack to response based on original request
116             # see RFC3261 "17.1.1.3 Construction of the ACK Request"
117             # Args: ($self,$response)
118             # $response: Net::SIP::Response object for request $self
119             # Returns: $cancel
120             # $ack: Net::SIP::Request object for ACK method
121             ###########################################################################
122             sub create_ack {
123 39     39 1 105 my Net::SIP::Request $self = shift;
124 39         78 my $response = shift;
125             # ACK uses cseq from request
126 39         217 $self->cseq =~m{(\d+)};
127 39         207 my $cseq = "$1 ACK";
128 39         84 my %auth;
129 39         110 for (qw(authorization proxy-authorization)) {
130 78 100       243 my $v = scalar($self->get_header($_)) or next;
131 2         15 $auth{$_} = $v;
132             }
133 39         151 my $header = {
134             'call-id' => scalar($self->get_header('call-id')),
135             from => scalar($self->get_header('from')),
136             # unlike CANCEL the 'to' header is from the response
137             to => [ $response->get_header('to') ],
138             via => [ ($self->get_header( 'via' ))[0] ],
139             route => [ $self->get_header( 'route' ) ],
140             cseq => $cseq,
141             %auth,
142             };
143 39         300 return Net::SIP::Request->new( 'ACK',$self->uri,$header );
144             }
145              
146             ###########################################################################
147             # Create cancel for request
148             # Args: $self
149             # Returns: $cancel
150             # $cancel: Net::SIP::Request containing CANCEL for $self
151             ###########################################################################
152             sub create_cancel {
153 6     6 1 17 my Net::SIP::Request $self = shift;
154             # CANCEL uses cseq from request
155 6         45 $self->cseq =~m{(\d+)};
156 6         48 my $cseq = "$1 CANCEL";
157 6         12 my %auth;
158 6         18 for (qw(authorization proxy-authorization)) {
159 12 50       34 my $v = scalar($self->get_header($_)) or next;
160 0         0 $auth{$_} = $v;
161             }
162 6         18 my $header = {
163             'call-id' => scalar($self->get_header('call-id')),
164             from => scalar($self->get_header('from')),
165             # unlike ACK the 'to' header is from the original request
166             to => [ $self->get_header('to') ],
167             via => [ ($self->get_header( 'via' ))[0] ],
168             route => [ $self->get_header( 'route' ) ],
169             cseq => $cseq,
170             %auth
171             };
172 6         24 return Net::SIP::Request->new( 'CANCEL',$self->uri,$header );
173             }
174              
175             ###########################################################################
176             # Create response to request
177             # Args: ($self,$code,[$msg],[$args,$body])
178             # $code: numerical response code
179             # $msg: msg for code, if arg not given it will be used from %ResponseCode
180             # $args: additional args for SIP header
181             # $body: body as string
182             # Returns: $response
183             # $response: Net::SIP::Response
184             ###########################################################################
185             sub create_response {
186 70     70 1 3879 my Net::SIP::Request $self = shift;
187 70         279 my $code = shift;
188 70 50 66     904 my ($msg,$args,$body) = ( defined $_[0] && ref($_[0]) ) ? (undef,@_):@_;
189 70 100       251 $msg = $ResponseCode{$code} if ! defined $msg;
190 70 100       303 my %header = (
191             cseq => scalar($self->get_header('cseq')),
192             'call-id' => scalar($self->get_header('call-id')),
193             from => scalar($self->get_header('from')),
194             to => [ $self->get_header('to') ],
195             'record-route' => [ $self->get_header( 'record-route' ) ],
196             via => [ $self->get_header( 'via' ) ],
197             $args ? %$args : ()
198             );
199 70         715 return Net::SIP::Response->new($code,$msg,\%header,$body);
200             }
201              
202              
203             ###########################################################################
204             # Authorize Request based on credentials in response using
205             # Digest Authorization specified in RFC2617
206             # Args: ($self,$response,@args)
207             # $response: Net::SIP::Response for $self which has code 401 or 407
208             # @args: either [ $user,$pass ] if there is one user+pass for all realms
209             # or { realm1 => [ $user,$pass ], realm2 => [...].. }
210             # for different user,pass in different realms
211             # or callback(realm)->[ user,pass ]
212             # Returns: 0|1
213             # 1: if (proxy-)=authorization headers were added to $self
214             # 0: if $self was not modified, e.g. no usable authenticate
215             # headers were found
216             ###########################################################################
217             sub authorize {
218 3     3 1 13 my Net::SIP::Request $self = shift;
219 3         7 my ($response,$user2pass) = @_;
220              
221             # find out format of user2pass
222 3         6 my ($default_upw,$realm2upw,$cb_upw);
223 3 50 33     25 if ( ref($user2pass) eq 'ARRAY' && ! ref( $user2pass->[0] )) {
    0          
224 3         8 $default_upw = $user2pass;
225             } elsif ( ref($user2pass) eq 'HASH' ) {
226 0         0 $realm2upw = %$user2pass;
227             } else {
228 0         0 $cb_upw = $user2pass;
229             }
230              
231              
232 3         4 my $auth = 0;
233 3         23 my %auth_map = (
234             'proxy-authenticate' => 'proxy-authorization',
235             'www-authenticate' => 'authorization',
236             );
237              
238 3         17 while ( my ($req,$resp) = each %auth_map ) {
239 6         13 my $existing_auth;
240 6 100       19 if ( my @auth = $response->get_header_hashval( $req ) ) {
241 3         6 foreach my $a (@auth) {
242 3         6 my $h = $a->{parameter};
243              
244             # check if we already have an authorize header for this realm/opaque
245 3 50       9 if ( ! $existing_auth ) {
246 3         4 $existing_auth = {};
247 3         11 foreach my $hdr ( $self->get_header_hashval( $resp )) {
248 0         0 my @auth = grep { defined } map { $hdr->{parameter}{$_} }qw( realm opaque );
  0         0  
  0         0  
249 0         0 $existing_auth->{ join( "\0",@auth ) } = 1;
250             }
251             }
252              
253 3         7 my @auth = grep { defined } map { $h->{$_} }qw( realm opaque );
  6         12  
  6         16  
254 3 50       13 if ( $existing_auth->{ join( "\0",@auth ) } ) {
255             # we have this auth header already, don't repeat
256 0         0 next;
257             }
258              
259             # RFC2617
260             # we support only md5 (not md5-sess or other)
261             # and only empty qop or qop=auth (not auth-int or other)
262              
263 3 50 33     40 if ( lc($a->{data}) ne 'digest'
      33        
      33        
      33        
264             || $h->{algorithm} && lc($h->{algorithm}) ne 'md5'
265             || $h->{qop} && $h->{qop} !~ m{(?:^|,\s*)auth(?:$|,)}i ) {
266 44     44   364 no warnings;
  44         86  
  44         24816  
267 0         0 DEBUG(10,"unsupported authorization method $a->{data} method=$h->{method} qop=$h->{qop}");
268 0         0 next;
269             }
270 3         7 my $realm = $h->{realm};
271             my $upw =
272             $cb_upw ? invoke_callback( $cb_upw, $realm ) :
273 3 50       10 $realm2upw ? $realm2upw->{$realm} :
    50          
    50          
274             $default_upw ? $default_upw :
275             next;
276              
277             # for meaning of a1,a2... and for the full algorithm see RFC2617, 3.2.2
278 3         9 my $a1 = join(':',$upw->[0],$realm,$upw->[1] ); # 3.2.2.2
279 3         8 my $a2 = join(':',$self->method,$self->uri ); # 3.2.2.3, qop == auth|undef
280              
281             my %digest = (
282             username => $upw->[0],
283             realm => $realm,
284             nonce => $h->{nonce},
285 3         11 uri => $self->uri,
286             );
287 3 50       11 $digest{opaque} = $h->{opaque} if defined $h->{opaque};
288              
289             # 3.2.2.1
290 3 50       7 if ( $h->{qop} ) {
291 0         0 $h->{qop} = 'auth'; # in case it was 'auth,auth-int'
292 0         0 my $nc = $digest{nc} = '00000001';
293 0         0 my $cnonce = $digest{cnonce} = sprintf("%08x",rand(2**32));
294 0         0 $digest{qop} = $h->{qop};
295             $digest{response} = md5_hex( join(':',
296             md5_hex($a1),
297             $h->{nonce},
298             $nc,
299             $cnonce,
300             $h->{qop},
301 0         0 md5_hex($a2)
302             ));
303             } else {
304             # 3.2.2.1 compability with RFC2069
305             $digest{response} = md5_hex( join(':',
306             md5_hex($a1),
307             $h->{nonce},
308 3         22 md5_hex($a2),
309             ));
310             }
311              
312             # RFC2617 has it's specific ideas what should be quoted and what not
313             # so we assemble it manually
314 3         20 my $header = qq[Digest username="$digest{username}",realm="$digest{realm}",].
315             qq[nonce="$digest{nonce}",uri="$digest{uri}",response="$digest{response}"];
316 3 50       7 $header.= qq[,opaque="$digest{opaque}"] if defined $digest{opaque};
317 3 50       7 $header.= qq[,cnonce="$digest{cnonce}"] if defined $digest{cnonce};
318 3 50       8 $header.= qq[,qop=$digest{qop}] if defined $digest{qop};
319 3 50       6 $header.= qq[,nc=$digest{nc}] if defined $digest{nc};
320 3         12 $self->add_header( $resp, $header );
321 3         22 $auth++;
322             }
323             }
324             }
325              
326 3 50       8 return if !$auth; # no usable authenticate headers found
327              
328 3         9 my ($rseq) = $response->cseq =~m{^(\d+)};
329 3         11 $self->cseq =~m{^(\d+)(.*)};
330 3 50 33     23 if ( defined $1 and $1 <= $rseq ) {
331             # increase cseq, because this will be a new request, not a retransmit
332 3         51 $self->set_header( cseq => ($rseq+1).$2 );
333             }
334              
335 3         14 return 1;
336             }
337              
338             1;