File Coverage

blib/lib/Catalyst/Authentication/Store/LDAP/User.pm
Criterion Covered Total %
statement 61 78 78.2
branch 16 26 61.5
condition 2 5 40.0
subroutine 20 25 80.0
pod 13 14 92.8
total 112 148 75.6


line stmt bran cond sub pod time code
1              
2             =pod
3              
4             =head1 NAME
5              
6             Catalyst::Authentication::Store::LDAP::User
7             - A User object representing an LDAP object.
8              
9             =head1 SYNOPSIS
10              
11             You should be creating these objects through L<Catalyst::Authentication::Store::LDAP::Backend>'s "get_user" method, or just letting $c->authenticate do
12             it for you.
13              
14             sub action : Local {
15             my ( $self, $c ) = @_;
16             $c->authenticate({
17             id => $c->req->param(username),
18             password => $c->req->param(password)
19             );
20             $c->log->debug($c->user->username . "is really neat!");
21             }
22              
23             If you access just $c->user in a scalar context, it will return the current
24             username.
25              
26             =head1 DESCRIPTION
27              
28             This wraps up an LDAP object and presents a simplified interface to it's
29             contents. It uses some AUTOLOAD magic to pass method calls it doesn't
30             understand through as simple read only accessors for the LDAP entries
31             various attributes.
32              
33             It gets grumpy if you ask for an attribute via the AUTOLOAD mechanism
34             that it doesn't know about. Avoid that with using "has_attribute",
35             discussed in more detail below.
36              
37             You can skip all that and just go straight to the L<Net::LDAP::Entry>
38             object through the "ldap_entry" method:
39              
40             my $entry = $c->user->ldap_entry;
41              
42             It also has support for Roles.
43              
44             =cut
45              
46             package Catalyst::Authentication::Store::LDAP::User;
47 11     11   14322 use base qw( Catalyst::Authentication::User Class::Accessor::Fast );
  11         14  
  11         4622  
48              
49 11     11   3178542 use strict;
  11         22  
  11         211  
50 11     11   36 use warnings;
  11         15  
  11         304  
51 11     11   41 use Scalar::Util qw/refaddr/;
  11         13  
  11         609  
52 11     11   2126 use Net::LDAP::Entry;
  11         311680  
  11         509  
53              
54             our $VERSION = '1.016';
55              
56 11     11   95 BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
57              
58 11     11   37277 use overload '""' => sub { shift->stringify }, fallback => 1;
  11     6   34  
  11         111  
  6         232  
59              
60             my %_ldap_connection_passwords; # Store inside-out so that they don't show up
61             # in dumps..
62              
63             =head1 METHODS
64              
65             =head2 new($store, $user, $c)
66              
67             Takes a L<Catalyst::Authentication::Store::LDAP::Backend> object
68             as $store, and the data structure returned by that class's "get_user"
69             method as $user. The final argument is an instance of your application,
70             which is passed along for those wanting to subclass User and perhaps use
71             models for fetching data.
72              
73             Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
74              
75             =cut
76              
77             sub new {
78 20     20 1 461 my ( $class, $store, $user, $c, $roles ) = @_;
79              
80 20 100       58 return unless $user;
81              
82 18         113 bless { store => $store, user => $user, _roles => $roles }, $class;
83             }
84              
85             =head2 id
86              
87             Returns the results of the "stringify" method.
88              
89             =cut
90              
91             sub id {
92 0     0 1 0 my $self = shift;
93 0         0 return $self->stringify;
94             }
95              
96             =head2 stringify
97              
98             Uses the "user_field" configuration option to determine what the "username"
99             of this object is, and returns it.
100              
101             If you use the special value "dn" for user_field, it will return the DN
102             of the L<Net::LDAP::Entry> object.
103              
104             =cut
105              
106             sub stringify {
107 8     8 1 12 my ($self) = @_;
108 8         36 my $userfield = $self->store->user_field;
109 8 50       1252 $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
110 8 50       23 if ( $userfield eq "dn" ) {
111 0         0 my ($string) = $self->user->ldap_entry->dn;
112 0         0 return $string;
113             }
114             else {
115 8         62 my $val = $self->$userfield;
116 8 50       47 return ref($val) eq 'ARRAY' ? $val->[0] : $val;
117             }
118             }
119              
120             =head2 supported_features
121              
122             Returns hashref of features that this Authentication::User subclass supports.
123              
124             =cut
125              
126             sub supported_features {
127             return {
128 0     0 1 0 password => { self_check => 1, },
129             session => 1,
130             roles => { self_check => 0, },
131             };
132             }
133              
134             =head2 check_password($password)
135              
136             Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
137             using the bind password supplied in $password. Returns 1 on a successful
138             bind, 0 on failure.
139              
140             =cut
141              
142             sub check_password {
143 3     3 1 131217 my ( $self, $password ) = @_;
144 3 50       59 if ( $self->store->ldap_auth($self->ldap_entry->dn, $password) ) {
145             # Stash a closure which can be used to retrieve the connection in the users context later.
146 3         414 $_ldap_connection_passwords{refaddr($self)} = $password;
147 3         19 return 1;
148             }
149             else {
150 0         0 return 0;
151             }
152             }
153              
154             =head2 roles
155              
156             Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
157              
158             =cut
159              
160             sub roles {
161 3     3 1 189 my $self = shift;
162 3   50     57 $self->{_roles} ||= [$self->store->lookup_roles($self)];
163 3         71 return @{$self->{_roles}};
  3         23  
164             }
165              
166             =head2 for_session
167              
168             Returns the user for persistence in the session depending on the
169             persist_in_session config option.
170              
171             Stores the persist_in_session setting so it can be used to revive the user
172             even if the setting has been changed.
173              
174             =cut
175              
176             sub for_session {
177 3     3 1 21 my $self = shift;
178              
179 3 100       30 if ( $self->store->persist_in_session eq 'all' ) {
180             # use the roles accessor to ensure the roles are fetched
181             return {
182             # store the persistance setting in the session to know how to
183             # restore the user
184 1         169 persist_in_session => $self->store->persist_in_session,
185             user => $self->user,
186             _roles => [ $self->roles ],
187             };
188             }
189              
190 2         1050 return $self->stringify;
191             }
192              
193             =head2 ldap_entry
194              
195             Returns the raw ldap_entry.
196              
197             =cut
198              
199             sub ldap_entry {
200 10     10 1 6537 my $self = shift;
201 10         34 return $self->user->{'ldap_entry'};
202             }
203              
204             =head2 attributes($type)
205              
206             Returns an array of attributes present for this user. If $type is "ashash",
207             it will return a hash with the attribute names as keys. (And the values of
208             those attributes as, well, the values of the hash)
209              
210             =cut
211              
212             sub attributes {
213 0     0 1 0 my ( $self, $type ) = @_;
214 0 0       0 if ( $type eq "ashash" ) {
215 0         0 return $self->user->{'attributes'};
216             }
217             else {
218 0         0 return keys( %{ $self->user->{'attributes'} } );
  0         0  
219             }
220             }
221              
222             =head2 has_attribute
223              
224             Returns the values for an attribute, or undef if that attribute is not present.
225             The safest way to get at an attribute.
226              
227             =cut
228              
229             sub has_attribute {
230 22     22 1 41 my ( $self, $attribute ) = @_;
231 22 50       59 if ( !defined($attribute) ) {
232 0         0 Catalyst::Exception->throw(
233             "You must provide an attribute to has_attribute!");
234             }
235 22 100       110 if ( $attribute eq "dn" ) {
    100          
    50          
236 4         7 return $self->ldap_entry->dn;
237             }
238             elsif ( $attribute eq "username" ) {
239 4         9 return $self->user->{'attributes'}->{$self->store->user_field};
240             }
241             elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
242 14         2086 return $self->user->{'attributes'}->{$attribute};
243             }
244             else {
245 0         0 return undef;
246             }
247             }
248              
249             =head2 get
250              
251             A simple wrapper around has_attribute() to satisfy the Catalyst::Authentication::User API.
252              
253             =cut
254              
255 0     0 1 0 sub get { return shift->has_attribute(@_) }
256              
257             =head2 get_object
258              
259             Satisfies the Catalyst::Authentication::User API and returns the contents of the user()
260             attribute.
261              
262             =cut
263              
264 0     0 1 0 sub get_object { return shift->user }
265              
266             =head2 ldap_connection
267              
268             Re-binds to the auth store with the credentials of the user you logged in
269             as, and returns a L<Net::LDAP> object which you can use to do further queries.
270              
271             =cut
272              
273             sub ldap_connection {
274 1     1 1 5 my $self = shift;
275             $self->store->ldap_bind( undef, $self->ldap_entry->dn,
276 1         3 $_ldap_connection_passwords{refaddr($self)} );
277             }
278              
279             =head2 AUTOLOADed methods
280              
281             We automatically map the attributes of the underlying L<Net::LDAP::Entry>
282             object to read-only accessor methods. So, if you have an entry that looks
283             like this one:
284              
285             dn: cn=adam,ou=users,dc=yourcompany,dc=com
286             cn: adam
287             loginShell: /bin/zsh
288             homeDirectory: /home/adam
289             gecos: Adam Jacob
290             gidNumber: 100
291             uidNumber: 1053
292             mail: adam@yourcompany.com
293             uid: adam
294             givenName: Adam
295             sn: Jacob
296             objectClass: inetOrgPerson
297             objectClass: organizationalPerson
298             objectClass: Person
299             objectClass: Top
300             objectClass: posixAccount
301              
302             You can call:
303              
304             $c->user->homedirectory
305              
306             And you'll get the value of the "homeDirectory" attribute. Note that
307             all the AUTOLOADed methods are automatically lower-cased.
308              
309             =head2 Special Keywords
310              
311             The highly useful and common method "username" will map to the configured
312             value of user_field (uid by default.)
313              
314             $c->user->username == $c->user->uid
315              
316             =cut
317              
318             sub DESTROY {
319 19     19   146130 my $self = shift;
320             # Don't leak passwords..
321 19         358 delete $_ldap_connection_passwords{refaddr($self)};
322             }
323              
324             sub can {
325 1     1 0 3 my ($self, $method) = @_;
326              
327 1   33     16 return $self->SUPER::can($method) || do {
328             return unless $self->has_attribute($method);
329 1     1   4 return sub { $_[0]->has_attribute($method) };
330             };
331             }
332              
333             sub AUTOLOAD {
334 17     17   3673 my $self = shift;
335              
336 17         148 ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
337              
338 17 50       60 if ( $method eq "DESTROY" ) {
339 0         0 return;
340             }
341              
342 17 50       65 if ( my $attribute = $self->has_attribute($method) ) {
343 17         1911 return $attribute;
344             }
345             else {
346 0           Catalyst::Exception->throw(
347             "No attribute $method for User " . $self->stringify );
348             }
349             }
350              
351             1;
352              
353             __END__
354              
355             =head1 AUTHORS
356              
357             Adam Jacob <holoway@cpan.org>
358              
359             Some parts stolen shamelessly and entirely from
360             L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
361              
362             Currently maintained by Peter Karman <karman@cpan.org>.
363              
364             =head1 THANKS
365              
366             To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
367              
368             =head1 SEE ALSO
369              
370             L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
371              
372             =head1 COPYRIGHT & LICENSE
373              
374             Copyright (c) 2005 the aforementioned authors. All rights
375             reserved. This program is free software; you can redistribute
376             it and/or modify it under the same terms as Perl itself.
377              
378             =cut
379