File Coverage

lib/Net/LDAP/SimpleServer/ProtocolHandler.pm
Criterion Covered Total %
statement 74 151 49.0
branch 7 48 14.5
condition 2 18 11.1
subroutine 19 29 65.5
pod 4 4 100.0
total 106 250 42.4


line stmt bran cond sub pod time code
1             package Net::LDAP::SimpleServer::ProtocolHandler;
2              
3 26     26   1576 use strict;
  26         71  
  26         1296  
4 26     26   166 use warnings;
  26         75  
  26         1496  
5              
6             # ABSTRACT: LDAP protocol handler used with Net::LDAP::SimpleServer
7              
8             our $VERSION = '0.0.20'; # VERSION
9              
10 26     26   172 use constant MD5_PREFIX => '{md5}';
  26         60  
  26         1652  
11              
12 26     26   8645 use Net::LDAP::Server;
  26         415463  
  26         1336  
13 26     26   262 use base 'Net::LDAP::Server';
  26         78  
  26         854  
14             use fields
15 26     26   6740 qw(store root_dn root_pw allow_anon user_passwords user_id_attr user_pw_attr user_filter);
  26         94  
  26         136  
16              
17 26     26   2989 use Carp;
  26         85  
  26         2132  
18 26     26   585 use Net::LDAP::LDIF;
  26         5495  
  26         1434  
19 26     26   3097 use Net::LDAP::Util qw{canonical_dn};
  26         138  
  26         1294  
20 26     26   9584 use Net::LDAP::Filter;
  26         52965  
  26         1055  
21 26     26   10274 use Net::LDAP::FilterMatch;
  26         168199  
  26         270  
22              
23 26         3457 use Net::LDAP::Constant qw/
24             LDAP_SUCCESS LDAP_INVALID_CREDENTIALS LDAP_AUTH_METHOD_NOT_SUPPORTED
25 26     26   90870 LDAP_INVALID_SYNTAX LDAP_NO_SUCH_OBJECT LDAP_INVALID_DN_SYNTAX/;
  26         103  
26              
27 26     26   472 use Net::LDAP::SimpleServer::LDIFStore;
  26         84  
  26         757  
28 26     26   197 use Net::LDAP::SimpleServer::Constant;
  26         84  
  26         2869  
29              
30 26     26   263 use Scalar::Util qw{reftype};
  26         83  
  26         1822  
31 26     26   222 use UNIVERSAL::isa;
  26         89  
  26         264  
32              
33 26     26   1287 use Digest::MD5 qw/md5/;
  26         84  
  26         1501  
34 26     26   9536 use MIME::Base64;
  26         15927  
  26         46025  
35              
36             sub _make_result {
37 0     0   0 my $code = shift;
38 0   0     0 my $dn = shift // '';
39 0   0     0 my $msg = shift // '';
40              
41             return {
42 0         0 matchedDN => $dn,
43             errorMessage => $msg,
44             resultCode => $code,
45             };
46             }
47              
48             sub new {
49 8     8 1 2555 my $class = shift;
50 8   66     183 my $params = shift || croak 'Must pass parameters!';
51              
52 7 100       194 croak 'Parameter must be a HASHREF' unless reftype($params) eq 'HASH';
53 5         9 for my $p (qw/store root_dn sock/) {
54 9 100       366 croak 'Must pass option {' . $p . '}' unless exists $params->{$p};
55             }
56             croak 'Not a LDIFStore'
57 1 50       4 unless $params->{store}->isa('Net::LDAP::SimpleServer::LDIFStore');
58              
59 1 50       28 croak 'Option {root_dn} can not be empty' unless $params->{root_dn};
60             croak 'Invalid root DN'
61 1 50       24 unless my $canon_dn = canonical_dn( $params->{root_dn} );
62              
63 1         98 my $self = $class->SUPER::new( $params->{sock} );
64 1         2576 $self->{store} = $params->{store};
65 1         2 $self->{root_dn} = $canon_dn;
66 1         3 $self->{root_pw} = $params->{root_pw};
67 1         2 $self->{allow_anon} = $params->{allow_anon};
68 1         2 $self->{user_passwords} = $params->{user_passwords};
69 1         2 $self->{user_id_attr} = $params->{user_id_attr};
70 1         2 $self->{user_pw_attr} = $params->{user_pw_attr};
71 1         2 $self->{user_filter} = $params->{user_filter};
72 1         3 chomp( $self->{root_pw} );
73 1         34 chomp( $self->{user_passwords} );
74              
75 1         5 return $self;
76             }
77              
78             sub unbind {
79 0     0 1   my $self = shift;
80              
81 0           $self->{store} = undef;
82 0           $self->{root_dn} = undef;
83 0           $self->{root_pw} = undef;
84              
85 0           return _make_result(LDAP_SUCCESS);
86             }
87              
88             sub _find_user_dn {
89 0     0     my ( $self, $username ) = @_;
90              
91             my $filter =
92             Net::LDAP::Filter->new( '(&'
93             . $self->{user_filter} . '('
94 0           . $self->{user_id_attr} . '='
95             . $username
96             . '))' );
97 0           return _match( $filter, $self->{store}->list() );
98             }
99              
100             sub _encode_password {
101 0     0     my $plain = shift;
102              
103 0           my $hashpw = encode_base64( md5($plain), '' );
104 0           return MD5_PREFIX . $hashpw;
105             }
106              
107             sub bind {
108             ## no critic (ProhibitBuiltinHomonyms)
109 0     0 1   my ( $self, $request ) = @_;
110              
111             # anonymous bind
112             return _make_result(LDAP_SUCCESS)
113             if ( $self->{allow_anon}
114             and not $request->{name}
115 0 0 0       and exists $request->{authentication}->{simple} );
      0        
116              
117             # As of now, accepts only simple authentication
118             return _make_result(LDAP_AUTH_METHOD_NOT_SUPPORTED)
119 0 0         unless exists $request->{authentication}->{simple};
120              
121 0           my $bind_pw = $request->{authentication}->{simple};
122 0           chomp($bind_pw);
123              
124 0           my $bind_dn = canonical_dn( $request->{name} );
125 0 0 0       unless ($bind_dn) {
126 0           my $search_user_result = $self->_find_user_dn( $request->{name} );
127 0           my $size = scalar( @{$search_user_result} );
  0            
128              
129             return _make_result( LDAP_INVALID_DN_SYNTAX, '',
130             'Cannot find user: ' . $request->{name} )
131 0 0         if $size == 0;
132             return _make_result( LDAP_INVALID_DN_SYNTAX, '',
133             'Cannot retrieve an unique user entry for id: ' . $request->{name} )
134 0 0         if $size > 1;
135              
136 0           $bind_dn = $search_user_result->[0];
137             }
138             elsif ( uc($bind_dn) ne uc( $self->{root_dn} ) ) {
139             my $search_dn_result =
140             $self->{store}->list_with_dn_scope( $bind_dn, SCOPE_BASEOBJ );
141             return _make_result( LDAP_INVALID_DN_SYNTAX, '',
142             'Cannot find user: ' . $request->{name} )
143             unless $search_dn_result;
144              
145             $bind_dn = $search_dn_result->[0];
146             }
147              
148 0 0         if ( $bind_dn->isa('Net::LDAP::Entry') ) {
    0          
149              
150             # user was not a dn, but it was found
151 0           my $entry_pw = $bind_dn->get_value( $self->{user_pw_attr} );
152              
153 0           my $regexp = '^' . MD5_PREFIX;
154 0 0         $entry_pw = _encode_password($entry_pw) if $entry_pw =~ /$regexp/;
155              
156 0 0         return _make_result( LDAP_INVALID_CREDENTIALS, undef,
157             'entry dn: ' . $bind_dn->dn() )
158             unless $entry_pw eq $bind_pw;
159             }
160             elsif ( uc($bind_dn) eq uc( $self->{root_dn} ) ) {
161             return _make_result( LDAP_INVALID_CREDENTIALS, undef,
162             'bind dn: ' . $bind_dn )
163 0 0         unless $bind_pw eq $self->{root_pw};
164             }
165             else {
166             return _make_result( LDAP_INVALID_DN_SYNTAX, '',
167 0           'Cannot find user: ' . $request->{name} );
168             }
169              
170 0           return _make_result(LDAP_SUCCESS);
171             }
172              
173             sub _match {
174 0     0     my ( $filter_spec, $elems ) = @_;
175              
176 0           my $f = bless $filter_spec, 'Net::LDAP::Filter';
177 0           return [ grep { $f->match($_) } @{$elems} ];
  0            
  0            
178             }
179              
180             sub _encode_pw_attr {
181 0     0     my ( $pw_attr, $entry ) = @_;
182              
183 0 0         return $entry unless grep { /person/ } $entry->get_value('objectclass');
  0            
184 0 0         return $entry unless $entry->exists($pw_attr);
185              
186 0           my $clone = $entry->clone();
187 0           my @pwlist = ();
188 0           my $regexp = '^' . MD5_PREFIX;
189 0           foreach ( $clone->get_value($pw_attr) ) {
190 0 0         next if /$regexp/;
191 0           push @pwlist, _encode_password($_);
192             }
193 0           $clone->delete($pw_attr);
194 0           $clone->add( $pw_attr => [@pwlist] );
195 0           return $clone;
196              
197             }
198              
199             sub _remove_pw_attr {
200 0     0     my ( $pw_attr, $entry ) = @_;
201              
202 0           my $clone = $entry->clone();
203 0 0         $clone->delete($pw_attr) if $clone->exists($pw_attr);
204 0           return $clone;
205             }
206              
207             sub _filter_attrs {
208 0     0     my ( $self, $list ) = @_;
209              
210             # TODO find a better way to keep the store read-only but not costly to return searches with filtered attributes
211 0 0         return $list if $self->{user_passwords} eq USER_PW_ALL;
212              
213 0           return [ map { _remove_pw_attr( $self->{user_pw_attr}, $_ ) } @{$list} ]
  0            
214 0 0         if $self->{user_passwords} eq USER_PW_NONE;
215              
216 0           return [ map { _encode_pw_attr( $self->{user_pw_attr}, $_ ) } @{$list} ]
  0            
217 0 0         if $self->{user_passwords} eq USER_PW_MD5;
218             }
219              
220             sub search {
221 0     0 1   my ( $self, $request ) = @_;
222              
223 0           my $list;
224 0 0         if ( defined( $request->{baseObject} ) ) {
225 0           my $basedn = canonical_dn( $request->{baseObject} );
226 0   0       my $scope = $request->{scope} || SCOPE_SUBTREE;
227              
228 0           $list = $self->{store}->list_with_dn_scope( $basedn, $scope );
229 0 0         return _make_result( LDAP_NO_SUCH_OBJECT, '',
230             'Cannot find BaseDN "' . $basedn . '"' )
231             unless defined($list);
232             }
233             else {
234 0           $list = $self->{store}->list();
235             }
236              
237 0           my $match = $self->_filter_attrs( _match( $request->{filter}, $list ) );
238              
239 0           return ( _make_result(LDAP_SUCCESS), @{$match} );
  0            
240             }
241              
242             1; # Magic true value required at end of module
243              
244             __END__