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