lib/Catalyst/Authentication/Store/LDAP/User.pm

   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 use base qw( Catalyst::Authentication::User Class::Accessor::Fast );
  48
  49 use strict;
  50 use warnings;
  51 use Scalar::Util qw/refaddr/;
  52 use Net::LDAP::Entry;
  53
  54 our $VERSION = '1.016';
  55
  56 BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
  57
  58 use overload '""' => sub { shift->stringify }, fallback => 1;
  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     my ( $class, $store, $user, $c, $roles ) = @_;
  79
  80     return unless $user;
  81
  82     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     my $self = shift;
  93     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     my ($self) = @_;
 108     my $userfield = $self->store->user_field;
 109     $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
 110     if ( $userfield eq "dn" ) {
 111         my ($string) = $self->user->ldap_entry->dn;
 112         return $string;
 113     }
 114     else {
 115         my $val = $self->$userfield;
 116         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         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     my ( $self, $password ) = @_;
 144     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         $_ldap_connection_passwords{refaddr($self)} = $password;
 147         return 1;
 148     }
 149     else {
 150         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     my $self = shift;
 162     $self->{_roles} ||= [$self->store->lookup_roles($self)];
 163     return @{$self->{_roles}};
 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     my $self = shift;
 178
 179     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             persist_in_session  => $self->store->persist_in_session,
 185             user                => $self->user,
 186             _roles              => [ $self->roles ],
 187         };
 188     }
 189
 190     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     my $self = shift;
 201     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     my ( $self, $type ) = @_;
 214     if ( $type eq "ashash" ) {
 215         return $self->user->{'attributes'};
 216     }
 217     else {
 218         return keys( %{ $self->user->{'attributes'} } );
 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     my ( $self, $attribute ) = @_;
 231     if ( !defined($attribute) ) {
 232         Catalyst::Exception->throw(
 233             "You must provide an attribute to has_attribute!");
 234     }
 235     if ( $attribute eq "dn" ) {
 236         return $self->ldap_entry->dn;
 237     }
 238     elsif ( $attribute eq "username" ) {
 239        return $self->user->{'attributes'}->{$self->store->user_field};
 240     }
 241     elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
 242         return $self->user->{'attributes'}->{$attribute};
 243     }
 244     else {
 245         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 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 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     my $self = shift;
 275     $self->store->ldap_bind( undef, $self->ldap_entry->dn,
 276         $_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     my $self = shift;
 320     # Don't leak passwords..
 321     delete $_ldap_connection_passwords{refaddr($self)};
 322 }
 323
 324 sub can {
 325     my ($self, $method) = @_;
 326
 327     return $self->SUPER::can($method) || do {
 328         return unless $self->has_attribute($method);
 329         return sub { $_[0]->has_attribute($method) };
 330     };
 331 }
 332
 333 sub AUTOLOAD {
 334     my $self = shift;
 335
 336     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 337
 338     if ( $method eq "DESTROY" ) {
 339         return;
 340     }
 341
 342     if ( my $attribute = $self->has_attribute($method) ) {
 343         return $attribute;
 344     }
 345     else {
 346         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