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
  53 our $VERSION = '1.014';
  54
  55 BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
  56
  57 use overload '""' => sub { shift->stringify }, fallback => 1;
  58
  59 my %_ldap_connection_passwords; # Store inside-out so that they don't show up
  60                                 # in dumps..
  61
  62 =head1 METHODS
  63
  64 =head2 new($store, $user, $c)
  65
  66 Takes a L<Catalyst::Authentication::Store::LDAP::Backend> object
  67 as $store, and the data structure returned by that class's "get_user"
  68 method as $user.  The final argument is an instance of your application,
  69 which is passed along for those wanting to subclass User and perhaps use
  70 models for fetching data.
  71
  72 Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
  73
  74 =cut
  75
  76 sub new {
  77     my ( $class, $store, $user, $c ) = @_;
  78
  79     return unless $user;
  80
  81     bless { store => $store, user => $user, }, $class;
  82 }
  83
  84 =head2 id
  85
  86 Returns the results of the "stringify" method.
  87
  88 =cut
  89
  90 sub id {
  91     my $self = shift;
  92     return $self->stringify;
  93 }
  94
  95 =head2 stringify
  96
  97 Uses the "user_field" configuration option to determine what the "username"
  98 of this object is, and returns it.
  99
 100 If you use the special value "dn" for user_field, it will return the DN
 101 of the L<Net::LDAP::Entry> object.
 102
 103 =cut
 104
 105 sub stringify {
 106     my ($self) = @_;
 107     my $userfield = $self->store->user_field;
 108     $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
 109     if ( $userfield eq "dn" ) {
 110         my ($string) = $self->user->ldap_entry->dn;
 111         return $string;
 112     }
 113     else {
 114         my $val = $self->$userfield;
 115         return ref($val) eq 'ARRAY' ? $val->[0] : $val;
 116     }
 117 }
 118
 119 =head2 supported_features
 120
 121 Returns hashref of features that this Authentication::User subclass supports.
 122
 123 =cut
 124
 125 sub supported_features {
 126     return {
 127         password => { self_check => 1, },
 128         session  => 1,
 129         roles    => { self_check => 0, },
 130     };
 131 }
 132
 133 =head2 check_password($password)
 134
 135 Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
 136 using the bind password supplied in $password.  Returns 1 on a successful
 137 bind, 0 on failure.
 138
 139 =cut
 140
 141 sub check_password {
 142     my ( $self, $password ) = @_;
 143     my $ldap
 144         = $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password,
 145         'forauth' );
 146     if ( defined($ldap) ) {
 147         if ($self->store->role_search_as_user) {
 148             # FIXME - This can be removed and made to use the code below..
 149             # Have to do the role lookup _now_, as this is the only time
 150             # that we have the user's password/ldap bind..
 151             $self->roles($ldap);
 152         }
 153         # Stash a closure which can be used to retrieve the connection in the users context later.
 154         $_ldap_connection_passwords{refaddr($self)} = $password;
 155         return 1;
 156     }
 157     else {
 158         return 0;
 159     }
 160 }
 161
 162 =head2 roles
 163
 164 Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
 165
 166 =cut
 167
 168 sub roles {
 169     my $self = shift;
 170     my $ldap = shift;
 171     $self->{_roles} ||= [$self->store->lookup_roles($self, $ldap)];
 172     return @{$self->{_roles}};
 173 }
 174
 175 =head2 for_session
 176
 177 Returns the User object, stringified.
 178
 179 =cut
 180
 181 sub for_session {
 182     my $self = shift;
 183     return $self->stringify;
 184 }
 185
 186 =head2 ldap_entry
 187
 188 Returns the raw ldap_entry.
 189
 190 =cut
 191
 192 sub ldap_entry {
 193     my $self = shift;
 194     return $self->user->{'ldap_entry'};
 195 }
 196
 197 =head2 attributes($type)
 198
 199 Returns an array of attributes present for this user.  If $type is "ashash",
 200 it will return a hash with the attribute names as keys. (And the values of
 201 those attributes as, well, the values of the hash)
 202
 203 =cut
 204
 205 sub attributes {
 206     my ( $self, $type ) = @_;
 207     if ( $type eq "ashash" ) {
 208         return $self->user->{'attributes'};
 209     }
 210     else {
 211         return keys( %{ $self->user->{'attributes'} } );
 212     }
 213 }
 214
 215 =head2 has_attribute
 216
 217 Returns the values for an attribute, or undef if that attribute is not present.
 218 The safest way to get at an attribute.
 219
 220 =cut
 221
 222 sub has_attribute {
 223     my ( $self, $attribute ) = @_;
 224     if ( !defined($attribute) ) {
 225         Catalyst::Exception->throw(
 226             "You must provide an attribute to has_attribute!");
 227     }
 228     if ( $attribute eq "dn" ) {
 229         return $self->ldap_entry->dn;
 230     }
 231     elsif ( $attribute eq "username" ) {
 232        return $self->user->{'attributes'}->{$self->store->user_field};
 233     }
 234     elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
 235         return $self->user->{'attributes'}->{$attribute};
 236     }
 237     else {
 238         return undef;
 239     }
 240 }
 241
 242 =head2 get
 243
 244 A simple wrapper around has_attribute() to satisfy the Catalyst::Authentication::User API.
 245
 246 =cut
 247
 248 sub get { return shift->has_attribute(@_) }
 249
 250 =head2 get_object
 251
 252 Satisfies the Catalyst::Authentication::User API and returns the contents of the user()
 253 attribute.
 254
 255 =cut
 256
 257 sub get_object { return shift->user }
 258
 259 =head2 ldap_connection
 260
 261 Re-binds to the auth store with the credentials of the user you logged in
 262 as, and returns a L<Net::LDAP> object which you can use to do further queries.
 263
 264 =cut
 265
 266 sub ldap_connection {
 267     my $self = shift;
 268     $self->store->ldap_bind( undef, $self->ldap_entry->dn,
 269         $_ldap_connection_passwords{refaddr($self)} );
 270 }
 271
 272 =head2 AUTOLOADed methods
 273
 274 We automatically map the attributes of the underlying L<Net::LDAP::Entry>
 275 object to read-only accessor methods.  So, if you have an entry that looks
 276 like this one:
 277
 278     dn: cn=adam,ou=users,dc=yourcompany,dc=com
 279     cn: adam
 280     loginShell: /bin/zsh
 281     homeDirectory: /home/adam
 282     gecos: Adam Jacob
 283     gidNumber: 100
 284     uidNumber: 1053
 285     mail: adam@yourcompany.com
 286     uid: adam
 287     givenName: Adam
 288     sn: Jacob
 289     objectClass: inetOrgPerson
 290     objectClass: organizationalPerson
 291     objectClass: Person
 292     objectClass: Top
 293     objectClass: posixAccount
 294
 295 You can call:
 296
 297     $c->user->homedirectory
 298
 299 And you'll get the value of the "homeDirectory" attribute.  Note that
 300 all the AUTOLOADed methods are automatically lower-cased.
 301
 302 =head2 Special Keywords
 303
 304 The highly useful and common method "username" will map to the configured
 305 value of user_field (uid by default.)
 306
 307     $c->user->username == $c->user->uid
 308
 309 =cut
 310
 311 sub DESTROY {
 312     my $self = shift;
 313     # Don't leak passwords..
 314     delete $_ldap_connection_passwords{refaddr($self)};
 315 }
 316
 317 sub can {
 318     my ($self, $method) = @_;
 319
 320     return $self->SUPER::can($method) || do {
 321         return unless $self->has_attribute($method);
 322         return sub { $_[0]->has_attribute($method) };
 323     };
 324 }
 325
 326 sub AUTOLOAD {
 327     my $self = shift;
 328
 329     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 330
 331     if ( $method eq "DESTROY" ) {
 332         return;
 333     }
 334
 335     if ( my $attribute = $self->has_attribute($method) ) {
 336         return $attribute;
 337     }
 338     else {
 339         Catalyst::Exception->throw(
 340             "No attribute $method for User " . $self->stringify );
 341     }
 342 }
 343
 344 1;
 345
 346 __END__
 347
 348 =head1 AUTHORS
 349
 350 Adam Jacob <holoway@cpan.org>
 351
 352 Some parts stolen shamelessly and entirely from
 353 L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
 354
 355 Currently maintained by Peter Karman <karman@cpan.org>.
 356
 357 =head1 THANKS
 358
 359 To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
 360
 361 =head1 SEE ALSO
 362
 363 L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
 364
 365 =head1 COPYRIGHT & LICENSE
 366
 367 Copyright (c) 2005 the aforementioned authors. All rights
 368 reserved. This program is free software; you can redistribute
 369 it and/or modify it under the same terms as Perl itself.
 370
 371 =cut
 372