1#! /usr/bin/perl 2# 3# 4# $Id: LDAP.pm 75 2009-08-12 22:08:28Z lem $ 5 6package Net::Radius::Server::Match::LDAP; 7 8use 5.008; 9use strict; 10use warnings; 11 12our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 }; 13 14use Net::LDAP; 15use Carp qw/croak/; 16use Net::Radius::Server::Base qw/:match/; 17use base qw/Net::Radius::Server::Match/; 18__PACKAGE__->mk_accessors(qw/ldap_uri ldap_opts bind_dn bind_opts search_opts 19 store_result max_tries tls_opts authenticate_from 20 /); 21 22sub _expand 23{ 24 my $self = shift; 25 my $r_list = shift || []; 26 my $r_data = shift || {}; 27 28 my @r = (); 29 30 die $self->description . ": Odd number of arguments\n" 31 if @$r_list % 2; 32 33 for (my $i = 0; 34 $i < @$r_list; 35 $i += 2) 36 { 37 my $k = $r_list->[$i]; 38 my $v = $r_list->[$i + 1]; 39 40 if ($k =~ m/^_nrs_(.+)$/ and ref($v) eq 'CODE') 41 { 42 push @r, $1, $v->($self, $r_data); 43 } 44 else 45 { 46 push @r, $k, $v; 47 } 48 } 49 50 @r; # Return the resulting set of arguments 51} 52 53sub _connect 54{ 55 my $self = shift; 56 my @args = $self->_expand($self->ldap_opts); 57 58 $self->log(4, "Connecting to LDAP: " . $self->ldap_uri . " " 59 . join(', ', @args)); 60 61 $self->{_ldap} = Net::LDAP->new($self->ldap_uri, @args); 62 63 die $self->description . 64 ": Failed to connect to LDAP server ", $self->ldap_uri, " ($!)\n" 65 unless $self->{_ldap}; 66} 67 68sub _bind 69{ 70 my $self = shift; 71 my $data = shift; 72 73 $self->_connect($data, @_); 74 75 my @args = $self->_expand($self->bind_opts, @_); 76 77 my $dn = $self->bind_dn; 78 79 if (ref($dn) eq 'CODE') 80 { 81 $dn = $dn->($self, $data, @_); 82 } 83 84 if ($self->authenticate_from) 85 { 86 my $attr = $self->authenticate_from; 87 my $pass = undef; 88 if (ref($attr) eq 'CODE') 89 { 90 $pass = $attr->($self, $data, @_); 91 } 92 else 93 { 94 $pass = $data->{request}->password($data->{secret}, $attr); 95 } 96 push @args, (password => $pass); 97 } 98 99 $self->log(4, "Binding to LDAP: " . ($dn || '(No DN)')); 100 my $r = $self->{_ldap}->bind($dn, @args); 101 102 # At this stage, a failure to bind is a fatal error... 103 if ($r->code) 104 { 105 $self->log(2, "LDAP bind failure: ". $r->error); 106 return; 107 } 108 return 1; 109} 110 111sub mk 112{ 113 my $proto = shift; 114 croak "->mk() cannot have arguments when in object-method mode\n" 115 if ref($proto) and $proto->isa('UNIVERSAL') and @_; 116 117 my $self = ref($proto) ? $proto : $proto->new(@_); 118 die "Failed to create new object\n" unless $self; 119 120 die $self->description . ": Must specify ldap_uri property\n" 121 unless $self->ldap_uri; 122 123 $self->_bind(@_) unless $self->authenticate_from; 124 125 return sub { $self->_match(@_) }; 126} 127 128sub match_ldap_uri 129{ 130 my $self = shift; 131 my $data = shift; 132 133 my $r; 134 my $tries = 0; 135 136 if ($self->authenticate_from 137 and not $self->_bind($data, @_)) 138 { 139 $self->log(2, "Not matched due to bind() failure - Aborting"); 140 return NRS_MATCH_FAIL; 141 } 142 143 return NRS_MATCH_OK if $self->authenticate_from 144 and not $self->search_opts; 145 146 do 147 { 148 $r = $self->{_ldap}->search($self->_expand($self->search_opts, 149 $data, @_));; 150 if ($r->code) 151 { 152 # Let's do a few attempts to query just in case... 153 if ($tries++ > ($self->max_tries || 2)) 154 { 155 $self->log(2, "Failed to issue the query - Aborting"); 156 return NRS_MATCH_FAIL; 157 } 158 159 $self->log(2, "Failure to query: " . $r->error); 160 unless ($self->_bind($data, @_)) 161 { 162 $self->log(2, "bind() failure"); 163 return NRS_MATCH_FAIL if $self->authenticate_from; 164 } 165 } 166 } until (!$r->code); 167 168 if ($self->store_result) 169 { 170 $self->log(4, "LDAP result stored"); 171 $data->{$self->store_result} = $r; 172 } 173 else 174 { 175 $self->log(4, "LDAP result discarded"); 176 } 177 178 my $c = $r->count; 179 if ($c) 180 { 181 $self->log(4, "LDAP query returned $c entries - match"); 182 return NRS_MATCH_OK; 183 } 184 else 185 { 186 $self->log(3, "LDAP query returned no entries - fail"); 187 return NRS_MATCH_FAIL; 188 } 189} 190 19142; 192 193__END__ 194 195=head1 NAME 196 197Net::Radius::Server::Match::LDAP - Interaction with LDAP servers for RADIUS 198 199=head1 SYNOPSIS 200 201 use Net::Radius::Server::Match::LDAP; 202 203 my $match = Net::Radius::Server::Match::LDAP->new({ ... }); 204 my $match_sub = $match->mk; 205 206=head1 DESCRIPTION 207 208C<Net::Radius::Server::Match::LDAP> is a packet match method 209factory. This allows a Net::Radius::Server(3) RADIUS server to process 210requests based on information stored in an LDAP 211directory. Additionally, information obtained from LDAP remains 212available for further rule methods to process. 213 214See C<Net::Radius::Server::Match> for general usage guidelines. The 215matching of RADIUS requests is controlled through arguments passed to 216the constructor, to specific accessors or to the factory method. There 217are generally, two types of arguments: 218 219=over 220 221=item B<Extendable> 222 223Those are arguments that are passed directly to a Net::LDAP(3) 224method. Those arguments can receive either a scalar or a code ref. 225 226If a scalar is supplied, this value is simply passed as-is to the 227undelying Net::LDAP(3) method. 228 229If a code ref is supplied, it will be called as in 230 231 $sub->($obj, $hashref); 232 233Where C<$obj> is the C<Net::Radius::Server::Match::LDAP> object and 234C<$hashref> is the invocation hashref, as described in 235Net::Radius::Server(3). Whatever is returned by this sub will be used 236as the value for this attribute. 237 238=item B<Indirect Extendable> 239 240The options that will be passed as named arguments to an underlying 241Net::LDAP(3) method. Generally speaking, those are attribute - value 242tuples specified within a listref, as in the following example. 243 244 ->bind_opts([ password => 'mySikritPzwrd' ]); 245 246Arguments are filtered to provide increased functionality. By 247prepending '_nrs_' to the argument name, 248C<Net::Radius::Server::Match::LDAP> will use the return value of the 249supplied code ref as the value of the argument. The following example 250illustrates this: 251 252 ->bind_ops([ _nrs_password => sub { 'mySikritPzwrd' } ]); 253 254The code ref is invoked as in 255 256 $sub->($obj, $hashref) 257 258Where C<$obj> is the C<Net::Radius::Server::Match::LDAP> object and 259C<$hashref> is the invocation hashref, as described in 260Net::Radius::Server(3). Whatever is returned by this sub will be used 261as the value for this attribute. 262 263=back 264 265The following arguments control the invocation of the Net::LDAP(3) 266underlying methods: 267 268=over 269 270=item B<ldap_uri> 271 272The URI or host specification passed as the first argument of 273C<Net::LDAP->new()>. See Net::LDAP(3) for more information. 274 275=item B<ldap_opts> (Indirect Extendable) 276 277The additional, named parameters passed to C<Net::LDAP->new()>. See 278Net::LDAP(3) for more information. 279 280=item B<bind_dn> (Extendable) 281 282The DN specification passed as the first argument of 283C<Net::LDAP->bind()>. See Net::LDAP(3) for more information. 284 285=item B<bind_opts> (Indirect Extendable) 286 287The additional, named parameters passed to C<Net::LDAP->bind()>. See 288Net::LDAP(3) for more information. 289 290=item B<authenticate_from> 291 292Specify an optional RADIUS attribute from which to extract the 293password for binding to the LDAP directory. A B<password => $pass> 294argument tuple will be added to whatever was specified with 295B<bind_opts>. 296 297Optionally, this parameter can also be a code ref, in which case it 298will be called as in 299 300 $obj->authenticate_from->($hashref) 301 302Where C<$hashref> is the shared invocation hash. The return value of 303the function will be used as the actual password to use in the LDAP 304binding. 305 306=item B<search_opts> (Indirect Extendable) 307 308The named paramenters passed to C<Net::LDAP->search()>. See 309Net::LDAP(3) for more information. 310 311=back 312 313The underlying Net::LDAP(3) object first attempts to C<-E<gt>bind()> 314when C<-E<gt>mk()> is called. This binding is re-attempted later, when 315errors are seen, depending on the configuration arguments specified. 316 317The match method will return C<NRS_MATCH_OK> if no error results from 318the LDAP C<-E<gt>search()>. 319 320The following methods control other aspects of the 321C<Net::Radius::Server::Match::LDAP>: 322 323=over 324 325=item B<store_result> 326 327When this argument is specified, the Net::LDAP::Result(3) object 328returned by the C<-E<gt>search()> method in Net::LDAP(3) will be 329stored in the invocation hashref. The value of this argument controls 330the name of the hash key where this result will be stored. 331 332This allows further methods (either on the same rule or in following 333rules) to use the information returned from an LDAP query for multiple 334purposes. You could, for example, locate a user's profile and allow 335later rules to translate that profile into RADIUS attributes in the 336response packet. 337 338=item B<max_tries> 339 340When attempting LDAP queries, a failure will cause the re-attempt to 341issue the C<-E<gt>bind()> call. This paramenter controls how many 342attempts are made. 2 attempts are made by default. 343 344=back 345 346=head2 EXPORT 347 348None by default. 349 350 351=head1 HISTORY 352 353 $Log$ 354 Revision 1.9 2006/12/14 16:33:17 lem 355 Rules and methods will only report failures in log level 3 and 356 above. Level 4 report success and failure, for deeper debugging 357 358 Revision 1.8 2006/11/15 03:11:22 lem 359 Minor indentation tweak 360 361 Revision 1.7 2006/11/15 01:57:37 lem 362 Fix CVS log in the docs 363 364 365=head1 SEE ALSO 366 367Perl(1), NetAddr::IP(3), Net::Radius::Server(3), 368Net::Radius::Server::Match(3), Net::LDAP(3). 369 370=head1 AUTHOR 371 372Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt> 373 374=head1 COPYRIGHT AND LICENSE 375 376Copyright (C) 2006 by Luis E. Muñoz 377 378This library is free software; you can redistribute it and/or modify 379it under the same terms as Perl 5.8.6 itself. 380 381=cut 382 383 384