File Coverage

blib/lib/STUN/RFC_5389.pm
Criterion Covered Total %
statement 61 79 77.2
branch 26 42 61.9
condition 25 40 62.5
subroutine 7 7 100.0
pod 5 5 100.0
total 124 173 71.6


line stmt bran cond sub pod time code
1             ################################################################################
2             #
3             # STUN::RFC_5389
4             #
5             # Perl implementation of RFC 5389, Session Traversal Utilities for NAT (STUN)
6             #
7             #
8             # This module is Copyright (C) 2010, Detlef Pilzecker, deti@cpan.org
9             # All Rights Reserved.
10             # This module is free software. It may be used, redistributed and/or modified
11             # under the same terms as Perl itself.
12             #
13             ################################################################################
14              
15              
16              
17             package STUN::RFC_5389;
18              
19 2     2   25085 use strict;
  2         5  
  2         83  
20 2     2   2341 use Socket;
  2         9566  
  2         5231  
21              
22             $STUN::RFC_5389::VERSION = '0.1';
23              
24              
25              
26              
27             ################################################################################
28             # STUN Attribute Registry
29             ################################################################################
30             %STUN::RFC_5389::attribute_registry = (
31             # Comprehension-required range (0x0000-0x7FFF):
32             # '0000' => (Reserved)
33             '0001' => 'MAPPED-ADDRESS',
34             # '0002' => (Reserved; was RESPONSE-ADDRESS)
35             # '0003' => (Reserved; was CHANGE-ADDRESS)
36             # '0004' => (Reserved; was SOURCE-ADDRESS)
37             # '0005' => (Reserved; was CHANGED-ADDRESS)
38             '0006' => 'USERNAME',
39             # '0007' => (Reserved; was PASSWORD)
40             '0008' => 'MESSAGE-INTEGRITY',
41             '0009' => 'ERROR-CODE',
42             '000A' => 'UNKNOWN-ATTRIBUTES',
43             # '000B' => (Reserved; was REFLECTED-FROM)
44             '0014' => 'REALM',
45             '0015' => 'NONCE',
46             '0020' => 'XOR-MAPPED-ADDRESS',
47              
48             # Comprehension-optional range (0x8000-0xFFFF)
49             '8022' => 'SOFTWARE',
50             '8023' => 'ALTERNATE-SERVER',
51             '8028' => 'FINGERPRINT',
52             );
53              
54              
55              
56              
57             ################################################################################
58             # STUN Attribute subroutines
59             # Args:
60             # attribute value string (client) | hashref with values for the sub (server)
61             # Return:
62             # hashref with values of the attribute (c)| attribute string in hex format (s)
63             ################################################################################
64             my %attribute_sub = (
65             'MAPPED-ADDRESS' => sub {
66             my $attr_value = shift;
67              
68             # build attribute
69             if ( ref $attr_value ) {
70             my $value = '00';
71             # IPv4
72             if ( $$attr_value{host} =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
73             # family 0x01
74             $value .= '01';
75             # X-port
76             $value .= sprintf( "%04x", $$attr_value{port} );
77             # X-address
78             $value .= sprintf( "%08x", unpack( "N", inet_aton( $$attr_value{host} ) ) );
79             }
80             # IPv6
81             else {
82             $STUN::RFC_5389::error .= "IPv6 is not supported at the moment!\n";
83             return '';
84             # family 0x02
85             #$value .= '02';
86             # X-Port
87             #$value .= sprintf( "%04x", $$attr_value{port} );
88             # X-Address
89             #$value .= sprintf( "%032x", $$attr_value{host} ^ 0x2112a442 . );
90             }
91              
92             return join_attribute( '0001', $value );
93             }
94              
95              
96             # parse attribute value
97             my %values;
98              
99             # 0x0001:IPv4
100             if ( $attr_value =~ s/^00(01)(....)// ) {
101             $values{family} = $1;
102             # X-Port
103             $values{port} = hex( $2 );
104             # X-Address
105             $values{address} = inet_ntoa( pack( "N", hex( $attr_value ) ) );
106             }
107             # 0x0002:IPv6
108             elsif ( $attr_value =~ s/^00(02)(....)// ) {
109             $STUN::RFC_5389::error .= "IPv6 is not supported at the moment!\n";
110             #$values{family} = $1;
111             # X-Port
112             #$values{port} = hex( $2 );
113             # X-Address
114             #$values{address} = inet_ntoa( pack( "N", hex( $attr_value ) ) );
115             }
116              
117             return \%values;
118             },
119              
120             'USERNAME' => sub {
121             my $attr_value = shift;
122             # XXXX not coded jet, returns just an empty string/hashref for now
123             # build attribute
124             if ( ref $attr_value ) {
125             my $value = '';
126              
127             return join_attribute( '0006', $value );
128             }
129              
130              
131             # parse attribute value
132             my %values;
133              
134             return \%values;
135             },
136              
137             'MESSAGE-INTEGRITY' => sub {
138             my $attr_value = shift;
139             # XXXX not coded jet, returns just an empty string/hashref for now
140             # build attribute
141             if ( ref $attr_value ) {
142             my $value = '';
143              
144             return join_attribute( '0008', $value );
145             }
146              
147              
148             # parse attribute value
149             my %values;
150              
151             return \%values;
152             },
153              
154             'ERROR-CODE' => sub {
155             my $attr_value = shift;
156             # XXXX not coded jet, returns just an empty string/hashref for now
157             # build attribute
158             if ( ref $attr_value ) {
159             my $value = '';
160              
161             return join_attribute( '0009', $value );
162             }
163              
164              
165             # parse attribute value
166             my %values;
167              
168             return \%values;
169             },
170              
171             'UNKNOWN-ATTRIBUTES' => sub {
172             my $attr_value = shift;
173             # XXXX not coded jet, returns just an empty string/hashref for now
174             # build attribute
175             if ( ref $attr_value ) {
176             my $value = '';
177              
178             return join_attribute( '000a', $value );
179             }
180              
181              
182             # parse attribute value
183             my %values;
184              
185             return \%values;
186             },
187              
188             'REALM' => sub {
189             my $attr_value = shift;
190             # XXXX not coded jet, returns just an empty string/hashref for now
191             # build attribute
192             if ( ref $attr_value ) {
193             my $value = '';
194              
195             return join_attribute( '0014', $value );
196             }
197              
198              
199             # parse attribute value
200             my %values;
201              
202             return \%values;
203             },
204              
205             'NONCE' => sub {
206             my $attr_value = shift;
207             # XXXX not coded jet, returns just an empty string/hashref for now
208             # build attribute
209             if ( ref $attr_value ) {
210             my $value = '';
211              
212             return join_attribute( '0015', $value );
213             }
214              
215              
216             # parse attribute value
217             my %values;
218              
219             return \%values;
220             },
221              
222             'XOR-MAPPED-ADDRESS' => sub {
223             my $attr_value = shift;
224              
225             # build attribute
226             if ( ref $attr_value ) {
227             my $value = '00';
228             # IPv4
229             if ( $$attr_value{host} =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
230             # family 0x01
231             $value .= '01';
232             # X-port
233             $value .= sprintf( "%04x", $$attr_value{port} ^ 0x2112 );
234             # X-address
235             $value .= sprintf( "%08x", unpack( "N", inet_aton( $$attr_value{host} ) ) ^ 0x2112a442 );
236             }
237             # IPv6
238             else {
239             $STUN::RFC_5389::error .= "IPv6 is not supported at the moment!\n";
240             return '';
241             # family 0x02
242             #$value .= '02';
243             # X-Port
244             #$value .= sprintf( "%04x", $$attr_value{port} ^ 0x2112 );
245             # X-Address
246             #$value .= sprintf( "%032x", $$attr_value{host} ^ 0x2112a442 . );
247             }
248              
249             return join_attribute( '0020', $value );
250             }
251              
252              
253             # parse attribute value
254             my %values;
255              
256             # 0x0001:IPv4
257             if ( $attr_value =~ s/^00(01)(....)// ) {
258             $values{family} = $1;
259             # X-Port
260             $values{port} = hex( $2 ) ^ 0x2112;
261             # X-Address
262             $values{address} = inet_ntoa( pack( "N", hex( $attr_value ) ^ 0x2112a442 ) );
263             }
264             # 0x0002:IPv6
265             elsif ( $attr_value =~ s/^00(02)(....)// ) {
266             $STUN::RFC_5389::error .= "IPv6 is not supported at the moment!\n";
267             #$values{family} = $1;
268             # X-Port
269             #$values{port} = hex( $2 ) ^ 0x2112;
270             # X-Address
271             #$values{address} = inet_ntoa( pack( "N", hex( $attr_value ) ^ 0x2112a442 ) );
272             }
273              
274             return \%values;
275             },
276              
277             'SOFTWARE' => sub {
278             my $attr_value = shift;
279              
280             # build attribute
281             if ( ref $attr_value ) {
282             # It MUST be a UTF-8 [RFC3629] encoded sequence of less than 128 characters
283             my $value = $$attr_value{software} ||
284             "Perl - STUN::RFC_5389 version $STUN::RFC_5389::VERSION at CPAN, by Detlef Pilzecker.";
285              
286             return join_attribute( '8022', unpack( "H*", sprintf( "%.128s", $value ) ) );
287             }
288              
289              
290             # parse attribute value
291             my %values;
292              
293             $values{software} = pack( "H*", $attr_value );
294              
295             return \%values;
296             },
297              
298             'ALTERNATE-SERVER' => sub {
299             my $attr_value = shift;
300             # XXXX not coded jet, returns just an empty string/hashref for now
301             # build attribute
302             if ( ref $attr_value ) {
303             my $value = '';
304              
305             return join_attribute( '8023', $value );
306             }
307              
308              
309             # parse attribute value
310             my %values;
311              
312             return \%values;
313             },
314              
315             'FINGERPRINT' => sub {
316             my $attr_value = shift;
317             # XXXX not coded jet, returns just an empty string/hashref for now
318             # build attribute
319             if ( ref $attr_value ) {
320             my $value = '';
321              
322             return join_attribute( '8028', $value );
323             }
324              
325              
326             # parse attribute value
327             my %values;
328              
329             return \%values;
330             },
331             );
332              
333              
334              
335              
336             ################################################################################
337             # join_attribute( $attr_type, $attr_value )
338             # join type, length and value of the attribute and will fix the length to
339             # become a 32-bit boundary length
340             # Args:
341             # $attr_type: attribute type in hex-format
342             # $attr_value: attribute value in hex-format
343             # Return: attribute string in hex format
344             ################################################################################
345             sub join_attribute {
346 2     2 1 4 my ( $attr_type, $attr_value ) = @_;
347              
348 2         2 my $a_len = length( $attr_value );
349 2 50       6 if ( $a_len % 2 != 0 ) {
350 0         0 $attr_value = '0' . $attr_value;
351 0         0 $a_len++;
352             }
353              
354 2   100     30 return $attr_type . sprintf( "%04x", $a_len / 2 ) . $attr_value . 0 x ( 8 - ( $a_len % 8 || 8 ) );
355             }
356              
357              
358              
359              
360             ################################################################################
361             # Client( $message_req_ind )
362             # do the RFC 5389 for the client
363             # Args:
364             # $message_req_ind: can be the received message from the STUN server or
365             # a hash_ref with attributes 'request' => 1 or 'indication' => 1
366             # Returns:
367             # hash reference with the STUN-server answer or
368             # STUN-client message to send if $message_req_ind was 'request' or
369             # 'indication' or
370             # '' on error (error message in $STUN::RFC_5389::error)
371             ################################################################################
372             sub Client {
373 3     3 1 1141 $STUN::RFC_5389::error = '';
374              
375 3         3 my $message = shift;
376 3 100       11 $message = $message ne 'STUN::RFC_5389' ? $message : shift; # strip the class
377              
378             # message to send
379 3 100       9 if ( ref $message ) {
380 2         2 my $message_type;
381 2 100       13 if ( $message->{request} ) {
    50          
382 1         4 $message_type = '0001';
383             }
384             elsif ( $message->{indication} ) {
385 1         2 $message_type = '0011';
386             }
387             else {
388 0         0 $STUN::RFC_5389::error .= "No hash-key with value 'request' or 'indication' set to true in hashref!\n";
389 0         0 return '';
390             }
391              
392             # No attributes jet coded for the client to send
393 2         4 my $message_length = 0;
394              
395             # In RFC 5389 the magic cookie field MUST contain this fixed value
396 2         3 my $magic_cookie = '2112a442';
397              
398             # The transaction ID is a 96-bit identifier, used to uniquely identify
399             # STUN transactions
400 2         3 my $transaction_id;
401 2         8 for ( my $i = 0; $i < 6; $i++ ) { $transaction_id .= sprintf("%04x", int( rand( 65536 ) ) ) }
  12         95  
402              
403 2         19 return pack( "H4nH8H24", $message_type, $message_length, $magic_cookie, $transaction_id );
404             }
405              
406              
407             # received message
408 1         2 my %received;
409 1         8 @received{ qw( message_type message_length magic_cookie transaction_id attributes ) } = unpack( "H4nH8H24H*", $message );
410              
411 1 50       4 return '' unless true_stun_message( @received{ qw( message_type message_length magic_cookie transaction_id attributes ) }, 0 );
412              
413 1         10 $received{attributes} = parse_attributes( $received{attributes} );
414              
415 1         3 return \%received;
416             }
417              
418              
419              
420              
421             ################################################################################
422             # parse_attributes( $attributes )
423             # parse all attributes
424             # Args:
425             # $attributes: stun message attributes in hex format
426             # Return: hashref with all attributes and its values in a hashref
427             ################################################################################
428             sub parse_attributes {
429 1     1 1 2 my $attributes = shift;
430              
431 1         2 my %attr;
432 1         6 while ( $attributes =~ s/^(....)(....)// ) {
433 2         6 my ( $type, $length ) = ( $1, $2 );
434              
435 2         4 $length = hex( $length ) * 2;
436 2   100     7 my $fixed_length = 8 - ( $length % 8 || 8 );
437 2 50       6 last if ( $length + $fixed_length ) > length( $attributes );
438              
439 2         3 my $attr_value = substr( $attributes, 0, $length, '' );
440 2 100       5 substr( $attributes, 0, $fixed_length, '' ) if $fixed_length;
441              
442 2 50 33     18 if ( length( $attr_value ) == $length && ( my $type_name = $STUN::RFC_5389::attribute_registry{ $type } ) ) {
443 2         4 $attr{ $type_name } = $attr{ $type } = $attribute_sub{ $type_name }->( $attr_value );
444             }
445             }
446              
447 1         2 return \%attr;
448             }
449              
450              
451              
452              
453             ################################################################################
454             # Server( $message, $port, $host )
455             # do the RFC 5389 for the server
456             # Args:
457             # $message: binary message string received from the client
458             # $port: port from which the message came
459             # $host: host IP from which the message came
460             # Returns:
461             # STUN-server message to send back or
462             # '' on error (error message in $STUN::RFC_5389::error) or
463             # if it was an indication
464             ################################################################################
465             sub Server {
466 2     2 1 683 $STUN::RFC_5389::error = '';
467              
468 2         2 my $message = shift;
469 2 100       6 $message = $message ne 'STUN::RFC_5389' ? $message : shift; # strip the class
470              
471 2         11 my ( $message_type, $message_length, $magic_cookie, $transaction_id, $attributes ) = unpack( "H4nH8H24H*", $message );
472              
473              
474 2 50       7 return '' unless true_stun_message( $message_type, $message_length, $magic_cookie, $transaction_id, $attributes, 1 );
475              
476             # No response is generated for an indication
477 2 100       9 return if $message_type eq '0011';
478              
479              
480             # Success response
481 1         2 $message_type = '0101';
482              
483 1         1 $attributes = '';
484              
485             # RFC 5389
486 1 50       3 if ( $magic_cookie eq '2112a442' ) {
487             # XOR-MAPPED-ADDRESS
488 1         7 $attributes .= $attribute_sub{'XOR-MAPPED-ADDRESS'}->( { port => shift, host => shift } );
489              
490             # SOFTWARE
491 1         5 $attributes .= $attribute_sub{'SOFTWARE'}->( {} );
492             }
493             # Probably RFC 3489
494             else {
495             # MAPPED-ADDRESS
496 0         0 $attributes .= $attribute_sub{'MAPPED-ADDRESS'}->( { port => shift, host => shift } );
497             }
498              
499 1         9 return pack( "H4nH8H24H*", $message_type, length( $attributes ) / 2, $magic_cookie, $transaction_id, $attributes );
500             }
501              
502              
503              
504              
505             ################################################################################
506             # true_stun_message( $message_type, $message_length, $magic_cookie, $transaction_id, $attributes, $i_am_server )
507             # check the message for errors
508             # Args:
509             # ...: unpacked stun message in an array with 5 values
510             # $i_am_server: set to true if check is done for server
511             # Return: (error) or 1 (success)
512             ################################################################################
513             sub true_stun_message {
514 3     3 1 7 my ( $message_type, $message_length, $magic_cookie, $transaction_id, $attributes, $i_am_server ) = @_;
515              
516 3 50       14 if ( $message_type !~ /^[0-3]/ ) {
517 0         0 $STUN::RFC_5389::error .= "The most significant 2 bits of every STUN message MUST be zeroes. Was 0x$message_type\n";
518 0         0 return;
519             }
520 3 50       8 if ( $message_length % 4 != 0 ) {
521 0         0 $STUN::RFC_5389::error .= "Message length was not correct: $message_length. All STUN attributes (and therefore the message length) MUST be padded to a multiple of 4 bytes!\n";
522 0         0 return;
523             }
524 3 50 66     30 if ( ( $message_length && ! $attributes ) ||
      66        
      33        
      33        
525             ( ! $message_length && $attributes ) ||
526             ( $message_length != length( $attributes ) / 2 ) ) {
527 0 0       0 $STUN::RFC_5389::error .= "Message length ($message_length) was not set correct. Must be (attributes length): " . ( $attributes ? length( $attributes ) / 2 : 0 ) . "\n";
528 0         0 return;
529             }
530 3 50       7 if ( $magic_cookie ne '2112a442' ) {
531 0         0 $STUN::RFC_5389::error .= "The magic cookie field MUST contain the fixed value 0x2112a442 to be RFC 5389 conform. I assume RFC 3489 here and let it pass. The value was: 0x$magic_cookie\n";
532             # Do not return; here because it's not explicitly an error
533             }
534 3 50 100     18 if ( $message_type ne '0001' && # Binding request
      66        
      33        
535             $message_type ne '0011' && # Binding indication
536             $message_type ne '0101' && # Binding success response
537             $message_type ne '0111' ) { # Binding error response
538 0         0 $STUN::RFC_5389::error .= "Message type (class and method) not recognised! Was: 0b$message_type\n";
539 0         0 return;
540             }
541 3 50 100     45 if ( $i_am_server &&
    50 66        
      66        
      33        
542             $message_type ne '0001' && $message_type ne '0011' ) {
543 0         0 $STUN::RFC_5389::error .= "Message type (class and method) are not for the server! Was: 0b$message_type\n";
544 0         0 return;
545             }
546             elsif ( ! $i_am_server &&
547             $message_type ne '0101' && $message_type ne '0111' ) {
548 0         0 $STUN::RFC_5389::error .= "Message type (class and method) are not for the client! Was: 0b$message_type\n";
549 0         0 return;
550             }
551              
552 3         9 return 1;
553             }
554              
555             1;