File Coverage

blib/lib/Data/Radius/Packet.pm
Criterion Covered Total %
statement 177 202 87.6
branch 62 94 65.9
condition 32 61 52.4
subroutine 19 20 95.0
pod 4 7 57.1
total 294 384 76.5


line stmt bran cond sub pod time code
1             package Data::Radius::Packet;
2             # encode/decode RADIUS protocol messages
3              
4 3     3   3314 use v5.10;
  3         10  
5 3     3   13 use strict;
  3         5  
  3         53  
6 3     3   10 use warnings;
  3         5  
  3         60  
7 3     3   12 use Carp ();
  3         4  
  3         32  
8 3     3   10 use Digest::MD5 ();
  3         6  
  3         29  
9 3     3   1604 use Digest::HMAC_MD5 ();
  3         3541  
  3         57  
10 3     3   1531 use bytes;
  3         35  
  3         13  
11              
12 3     3   99 use base qw(Class::Accessor::Fast);
  3         5  
  3         329  
13             __PACKAGE__->mk_accessors(qw(secret dict));
14              
15 3     3   16 use Data::Radius::Constants qw(:all);
  3         6  
  3         406  
16 3     3   1146 use Data::Radius::Encode qw(encode);
  3         7  
  3         180  
17 3     3   1226 use Data::Radius::Decode qw(decode);
  3         8  
  3         193  
18 3     3   31 use Data::Radius::Util qw(encrypt_pwd decrypt_pwd is_enum_type);
  3         5  
  3         140  
19              
20             use constant {
21             # common attributes
22 3         5369 ATTR_PASSWORD => 2,
23             ATTR_VENDOR => 26,
24             # Message-Authenticator
25             ATTR_MSG_AUTH_NAME => 'Message-Authenticator',
26             ATTR_MSG_AUTH => 80,
27             ATTR_MSG_AUTH_LEN => 18,
28              
29             # has extra byte in VSA header
30             WIMAX_VENDOR => 24757,
31 3     3   15 };
  3         4  
32              
33             my %IS_REPLY = map { $_ => 1 } (ACCESS_ACCEPT, ACCESS_REJECT, DISCONNECT_ACCEPT, DISCONNECT_REJECT, COA_ACCEPT, COA_REJECT);
34             my %IS_REQUEST = map { $_ => 1 } (ACCESS_REQUEST, ACCOUNTING_REQUEST, DISCONNECT_REQUEST, COA_REQUEST);
35              
36             my $request_id = int( rand(255) );
37              
38             # Digest::MD5 object
39             my $md5;
40              
41             sub new {
42 4     4 1 2270 my ($class, %h) = @_;
43             my $obj = {
44             secret => $h{secret},
45             dict => $h{dict},
46 4         15 };
47              
48 4         15 bless $obj, $class;
49             }
50              
51             # build new request
52             # input:
53             # type - radius code
54             # authenticator - for access request allow to override random one,
55             # for replies - value from request must be used
56             # av_list - array-ref of AV in {Name, Value} or {Id,Type,VendorId,Value} form
57             # dict - allow to override default dictionary object from constructor
58             # secret - allow to override default secret from constructor
59             # with_msg_auth - boolean, to add Message-Authenticator.
60             # This can be archieved by adding Message-Authenticator to av_list with undefined value
61             # request_id - allow to specify custom value (0..255), otherwise internal counter is used
62             # RaiseError - raise error from AV encoding/decoding - default is to print and forgive errors
63             # PrintError - print error from AV encoding/decoding - default on
64             sub build {
65 4     4 1 3095 my ($self, %h) = @_;
66              
67 4   33     39 $h{RaiseError} //= $Data::Radius::Encode::RaiseError;
68 4   33     20 $h{PrintError} //= $Data::Radius::Encode::PrintError;
69              
70             # RADIUS code
71 4         6 my $type = $h{type};
72             # list in form of { Name => ... Value => ... [Vendor => ...]}
73 4         20 my $av_list = $h{av_list};
74             # object of Data::Radius::Dictionary or compatible
75 4   33     108 my $dict = $h{dict} // $self->dict();
76             # RADIUS secret
77 4 50       33 if($h{secret}) {
78 0         0 $self->secret($h{secret});
79             }
80 4 50       65 Carp::croak('No secret value') if ! defined $self->secret;
81             # enable adding Message-Authenticator attribute (RFC3579)
82             # enable it by defaulf if Message-Authenticator is present in av_list with empty value
83 4         40 my $with_msg_auth = $h{with_msg_auth};
84              
85 4 50 33     13 if ($self->is_reply($type) && ! $h{authenticator}) {
86 0         0 Carp::croak("No authenticator value from request");
87             }
88              
89             # Authenticator required now to encode password field (if present)
90 4         7 my $authenticator;
91 4 100       20 if ($type == ACCESS_REQUEST) {
92             # random, but allow to override for testing
93 3   33     9 $authenticator = $h{authenticator} // pack 'L4', map { int(rand(2 ** 32 - 1)) } (0..3);
  0         0  
94             }
95              
96             # pack attributes
97 4         8 my @bin_av = ();
98 4         7 foreach my $av (@{$av_list}) {
  4         8  
99             # Message-Authenticator
100 11 100 66     37 if (($av->{Name} eq ATTR_MSG_AUTH_NAME) && !$av->{Value}) {
101 1         3 $with_msg_auth = 1;
102             # this AV will be calculated and added to the end of list
103 1         1 next;
104             }
105              
106 10         24 my $bin = eval { $self->pack_attribute($av, $authenticator) };
  10         26  
107 10 50       24 if ($@) {
108 0         0 my $msg = $@;
109 0 0       0 Carp::croak($msg) if $h{RaiseError};
110 0 0       0 Carp::carp ($msg) if $h{PrintError};
111             }
112 10 50       40 push (@bin_av, $bin) if $bin;
113             }
114              
115 4         12 my $attributes = join('', @bin_av);
116              
117             # build packet header
118              
119 4         8 my $length = 20 + length($attributes);
120              
121             # generate new sequential id if not given (one byte size)
122 4   33     25 my $req_id = $h{request_id} // ($request_id++) & 0xff;
123              
124             # RFC3579 Message-Authenticator (EAP)
125 4 100       9 if($with_msg_auth) {
126             # calculate and append Message-Authenticator attribute
127 3         6 $length += ATTR_MSG_AUTH_LEN;
128 3         5 my $msg_auth = "\x0" x (ATTR_MSG_AUTH_LEN - 2);
129              
130 3         5 my $used_auth;
131 3 100       13 if ($type == ACCESS_REQUEST) {
    50          
132             # random-generated
133 2         2 $used_auth = $authenticator;
134             }
135             elsif ($self->is_request($type)) {
136             # Message-Authenticator should not be present in ACCOUNTING_REQUEST
137 1         2 $used_auth = "\x00" x 16;
138             }
139             else {
140             # must be passed when composing replies
141 0         0 $used_auth = $h{authenticator};
142             }
143              
144 3         14 my $data = join('',
145             pack('C C n', $type, $req_id, $length),
146             $used_auth,
147             $attributes,
148             pack('C C', ATTR_MSG_AUTH, ATTR_MSG_AUTH_LEN),
149             $msg_auth,
150             );
151              
152 3         54 my $hmac = Digest::HMAC_MD5->new($self->secret);
153 3         141 $hmac->add( $data );
154 3         24 $msg_auth = $hmac->digest;
155              
156 3         72 $attributes .= pack('C C', ATTR_MSG_AUTH, ATTR_MSG_AUTH_LEN) . $msg_auth;
157             }
158              
159             # calculate authentificator value for non-authentication request
160 4 100       12 if (! $authenticator) {
161             # calculated from content
162 1 50       3 my $used_auth = $self->is_request($type) ? "\x0" x 16 : $h{authenticator};
163              
164 1         5 my $hdr = pack('C C n', $type, $req_id, $length);
165 1   33     12 $md5 //= Digest::MD5->new;
166 1         20 $md5->add($hdr, $used_auth, $attributes, $self->secret);
167 1         8 $authenticator = $md5->digest();
168             }
169              
170             # wtf?
171 4 50       9 Carp::croak("No authenticator") if ! $authenticator;
172              
173 4         18 my $packet = join('',
174             pack('C C n', $type, $req_id, $length),
175             $authenticator,
176             $attributes,
177             );
178              
179 4         19 return ($packet, $req_id, $authenticator);
180             }
181              
182             # authenticator required only for password attribute
183             # av: {Name,Value,[Tag]} or {Id,Type,Value,[VendorId],[Tag]}
184             sub pack_attribute {
185 13     13 0 1112 my ($self, $av, $authenticator) = @_;
186              
187             # optional
188 13         250 my $dict = $self->dict;
189              
190 13         53 my $attr;
191             my $vendor_id;
192              
193             # attribute not present in dictionary must be passed as {Id, Type, Value, VendorId, Tag },
194             # where VendorId and Tag are optional
195 13 100       37 if ($av->{Id}) {
    50          
196 2 50       4 die "No attribute type for $av->{Id}\n" if ! $av->{Type};
197             $attr = {
198             id => $av->{Id},
199             name => $av->{Id},
200             type => $av->{Type},
201             vendor => $av->{VendorId},
202             has_tag => defined $av->{Tag},
203 2         9 };
204 2         3 $vendor_id = $av->{VendorId};
205             }
206             elsif (defined $av->{Name}) {
207             # av: {Name, Value}
208 11 50       22 die "No dictionary to encode attribute '$av->{Name}'\n" if ! $dict;
209              
210             # tagged attribute
211 11 100       32 if ($av->{Name} =~ /^([\w-]+):(\d+)$/) {
212 2         20 ($av->{Name}, $av->{Tag}) = ($1, $2);
213             }
214              
215             $attr = $dict->attribute($av->{Name})
216 11 50       33 or die "Unknown attribute '$av->{Name}'\n";
217              
218             # TODO store vendor_id in dictionary parser
219 11         87 $vendor_id = $dict->vendor_id($attr->{vendor});
220             }
221              
222 13 100       40 if (defined $av->{Tag}) {
223             die "Tag value $av->{Tag} is out of range [1..31] for attribute '$attr->{name}'\n"
224 3 50 33     23 if $av->{Tag} < 1 || $av->{Tag} > 31;
225             }
226              
227 13         23 my $value = $av->{Value};
228 13 50       32 die "Undefined value for attribute '$attr->{name}'\n" unless defined $value;
229              
230 13 100 66     50 if ($attr->{id} == ATTR_PASSWORD && ! $vendor_id) {
231             # need an authenticator - this attribute must be present only in ACCESS REQUEST
232 3         46 $value = encrypt_pwd($value, $self->secret, $authenticator);
233             }
234              
235 13 100 66     63 if ($attr->{type} ne 'tlv' && is_enum_type($attr->{type}) && $dict) {
      100        
236             # convert constant-like values to real value
237 2   66     7 $value = $dict->value($attr->{name}, $value) // $value;
238             } # else - for TVL type value is ARRAY-ref
239              
240 13         59 local ($Data::Radius::Encode::PrintError, $Data::Radius::Encode::RaiseError) = (0,1);
241 13         228 my $encoded = encode($attr, $value, $self->dict, $av->{Tag} );
242 13 50       32 my $len_encoded = length($encoded)
243             or die "Unable to encode value for attribute '$attr->{name}'\n";
244              
245 13 100       24 if (! $vendor_id) {
246             # tag already included into value, if any
247 10         59 return pack('C C', $attr->{id}, $len_encoded + 2) . $encoded;
248             }
249              
250             # VSA
251              
252 3         4 my $vsa_header;
253 3 100       8 if ($vendor_id == WIMAX_VENDOR) {
254 1         4 $vsa_header = pack('N C C C', $vendor_id, $attr->{id}, $len_encoded + 3, 0);
255             }
256             else {
257             # tag already included into value, if any
258 2         8 $vsa_header = pack('N C C', $vendor_id, $attr->{id}, $len_encoded + 2);
259             }
260              
261 3         14 return pack('C C', ATTR_VENDOR, length($vsa_header) + $len_encoded + 2) . $vsa_header . $encoded;
262             }
263              
264             # parse binary-encoded radius packet
265             # returns list: type, request-id, authenticator, \@AV_list
266             sub parse {
267 3     3 1 6070 my ($self, $packet, $orig_auth) = @_;
268              
269 3         72 my $dict = $self->dict;
270              
271 3         31 my($type, $req_id, $length, $auth, $attributes) = unpack('C C n a16 a*', $packet);
272              
273             # Validate authenticator field
274 3         9 my $expected_auth;
275 3 100       12 if ($type == ACCESS_REQUEST) {
276             # authenticator is random value - no validation
277             }
278             else {
279 1         2 my $used_auth;
280 1 50       3 if ($self->is_request($type)) {
281 1         2 $used_auth = "\x00" x 16;
282             }
283             else {
284             # fo replied we have to use authenticator from request:
285 0 0       0 if (! $orig_auth) {
286 0         0 warn "No original authenticator - unable to verify reply";
287 0         0 return undef;
288             }
289 0         0 $used_auth = $orig_auth;
290             }
291              
292 1   33     4 $md5 //= Digest::MD5->new;
293              
294 1         4 my $hdr = pack('C C n', $type, $req_id, $length);
295 1         17 $md5->add($hdr, $used_auth, $attributes, $self->secret);
296 1         11 $expected_auth = $md5->digest();
297              
298 1 50       4 if($auth ne $expected_auth) {
299 0         0 warn "Bad authenticator value";
300 0         0 return undef;
301             }
302             }
303              
304             # decode attributes
305 3         7 my @attr;
306             my $msg_auth;
307 3         5 my $pos = 0;
308 3         6 my $len = length($attributes);
309              
310 3         12 while ($pos < $len) {
311 10         27 my ($attr_val, $vendor_id, $vendor, $vsa_len, $attr, $tag) = ();
312             # FIXME not supported
313 10         12 my $wimax_cont;
314              
315 10         30 my ($attr_id, $attr_len) = unpack('C C', substr($attributes, $pos, 2));
316              
317 10 100       22 if ($attr_id == ATTR_VENDOR) {
318 1         2 my $vsa_header_len = 6;
319              
320 1         4 ($vendor_id, $attr_id, $vsa_len) = unpack('N C C', substr($attributes, $pos + 2, $vsa_header_len) );
321 1 50       3 if ($vendor_id == WIMAX_VENDOR) {
322             # +1 continuation byte
323 0         0 $vsa_header_len = 7;
324 0         0 $wimax_cont = unpack('C', substr($attributes, $pos + 8, 1));
325 0 0       0 warn 'continuation field is not supported' if ($wimax_cont);
326 0         0 printf "WIMAX cont: %d\n", $wimax_cont;
327             }
328              
329 1 50       3 if ($dict) {
330 1   33     10 $vendor = $dict->vendor_name($vendor_id) // $vendor_id;
331 1         9 $attr = $dict->attribute_name($vendor, $attr_id);
332             }
333              
334 1         7 $attr_val = substr($attributes, $pos + 2 + $vsa_header_len, $attr_len - 2 - $vsa_header_len);
335             }
336             else {
337 9 50       17 if ($dict) {
338 9         32 $attr = $dict->attribute_name(undef, $attr_id);
339             }
340              
341 9         96 $attr_val = substr($attributes, $pos + 2, $attr_len - 2);
342             }
343              
344 10 100 66     29 if ($attr_id == ATTR_MSG_AUTH && ! $vendor) {
345 2 50       6 die "Invalid Message-Authenticator len" if ($attr_len != 18);
346 2         5 $msg_auth = $attr_val;
347             # zero it to verify later
348 2         4 $attr_val = "\x0" x (ATTR_MSG_AUTH_LEN - 2);
349 2         4 substr($attributes, $pos + 2, $attr_len - 2, $attr_val);
350             }
351              
352 10         14 $pos += $attr_len;
353              
354 10 50       19 if (! $attr) {
355             # raw data for unknown attribute
356 0         0 push @attr, {
357             Name => $attr_id,
358             Value => $attr_val,
359             Type => undef,
360             Vendor => $vendor,
361             Tag => undef,
362             };
363 0         0 next;
364             }
365              
366 10         154 (my $decoded, $tag) = decode($attr, $attr_val, $self->dict);
367 10 100       35 if (is_enum_type($attr->{type})) {
368             # try to convert value to constants
369 2   66     6 $decoded = $dict->constant($attr->{name}, $decoded) // $decoded;
370             }
371              
372             # password is expected only in auth request
373 10 100 100     110 if ($type == ACCESS_REQUEST && $attr->{id} == ATTR_PASSWORD && ! $attr->{vendor}) {
      66        
374 2         63 $decoded = decrypt_pwd($decoded, $self->secret, $auth);
375             }
376              
377             push @attr, {
378             Name => $attr->{name},
379             Value => $decoded,
380             Type => $attr->{type},
381 10         58 Vendor => $vendor,
382             Tag => $tag,
383             };
384             }
385              
386 3 100       9 if($msg_auth) {
387             # we already replaced msg auth value to \x0...
388 2         4 my $auth_used;
389 2 50       53 if ($self->is_reply($type)) {
    100          
390 0         0 $auth_used = $orig_auth;
391             }
392             elsif ($type == ACCESS_REQUEST) {
393 1         2 $auth_used = $auth;
394             }
395             else {
396             # other type of request should use 00x16
397             # Message-Authenticator should not be present in ACCOUNTING_REQUEST
398 1         3 $auth_used = "\x00" x 16;
399             }
400              
401 2         37 my $data = join('',
402             pack('C C n', $type, $req_id, $length),
403             $auth_used,
404             $attributes,
405             );
406 2         43 my $hmac = Digest::HMAC_MD5->new($self->secret);
407 2         60 $hmac->add( $data );
408 2         14 my $exp_msg_auth = $hmac->digest;
409              
410 2 50       39 if ($msg_auth ne $exp_msg_auth) {
411 0         0 warn "Message-Authenticator not verified";
412 0         0 return undef;
413             }
414             }
415              
416 3         26 return ($type, $req_id, $auth, \@attr);
417             }
418              
419             # extract request id from packet header without parsing attributes
420             # should be used to find original authenticator value for received reply packet to pass it to decode_request()
421             sub request_id {
422 0     0 1 0 my ($self, $packet) = @_;
423 0         0 my $req_id = unpack('C', substr($packet, 1, 1));
424 0         0 return $req_id;
425             }
426              
427             sub is_reply {
428 6     6 0 13 my ($class, $type) = @_;
429 6   50     47 return $IS_REPLY{ $type } // 0;
430             }
431              
432             sub is_request {
433 3     3 0 7 my ($class, $type) = @_;
434 3   50     13 return $IS_REQUEST{ $type } // 0;
435             }
436              
437             1;
438              
439             __END__