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/) }
  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( sub { $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password ) } );
 149         return 1;
 150     }
 151     else {
 152         return 0;
 153     }
 154 }
 155
 156 =head2 roles
 157
 158 Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
 159
 160 =cut
 161
 162 sub roles {
 163     my $self = shift;
 164     my $ldap = shift;
 165     $self->{_roles} ||= [$self->store->lookup_roles($self, $ldap)];
 166     return @{$self->{_roles}};
 167 }
 168
 169 =head2 for_session
 170
 171 Returns the User object, stringified.
 172
 173 =cut
 174
 175 sub for_session {
 176     my $self = shift;
 177     return $self->stringify;
 178 }
 179
 180 =head2 ldap_entry
 181
 182 Returns the raw ldap_entry.
 183
 184 =cut
 185
 186 sub ldap_entry {
 187     my $self = shift;
 188     return $self->user->{'ldap_entry'};
 189 }
 190
 191 =head2 attributes($type)
 192
 193 Returns an array of attributes present for this user.  If $type is "ashash",
 194 it will return a hash with the attribute names as keys. (And the values of
 195 those attributes as, well, the values of the hash)
 196
 197 =cut
 198
 199 sub attributes {
 200     my ( $self, $type ) = @_;
 201     if ( $type eq "ashash" ) {
 202         return $self->user->{'attributes'};
 203     }
 204     else {
 205         return keys( %{ $self->user->{'attributes'} } );
 206     }
 207 }
 208
 209 =head2 has_attribute
 210
 211 Returns the values for an attribute, or undef if that attribute is not present.
 212 The safest way to get at an attribute.
 213
 214 =cut
 215
 216 sub has_attribute {
 217     my ( $self, $attribute ) = @_;
 218     if ( !defined($attribute) ) {
 219         Catalyst::Exception->throw(
 220             "You must provide an attribute to has_attribute!");
 221     }
 222     if ( $attribute eq "dn" ) {
 223         return $self->ldap_entry->dn;
 224     }
 225     elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
 226         return $self->user->{'attributes'}->{$attribute};
 227     }
 228     else {
 229         return undef;
 230     }
 231 }
 232
 233 =head2 AUTOLOADed methods
 234
 235 We automatically map the attributes of the underlying L<Net::LDAP::Entry>
 236 object to read-only accessor methods.  So, if you have an entry that looks
 237 like this one:
 238
 239     dn: cn=adam,ou=users,dc=yourcompany,dc=com
 240     cn: adam
 241     loginShell: /bin/zsh
 242     homeDirectory: /home/adam
 243     gecos: Adam Jacob
 244     gidNumber: 100
 245     uidNumber: 1053
 246     mail: adam@yourcompany.com
 247     uid: adam
 248     givenName: Adam
 249     sn: Jacob
 250     objectClass: inetOrgPerson
 251     objectClass: organizationalPerson
 252     objectClass: Person
 253     objectClass: Top
 254     objectClass: posixAccount
 255
 256 You can call:
 257
 258     $c->user->homedirectory
 259
 260 And you'll get the value of the "homeDirectory" attribute.  Note that
 261 all the AUTOLOADed methods are automatically lower-cased.
 262
 263 =head2 Special Keywords
 264
 265 The highly useful and common method "username" will map to the configured
 266 value of user_field (uid by default.)
 267
 268     $c->user->username == $c->user->uid
 269
 270 =cut
 271
 272 sub AUTOLOAD {
 273     my $self = shift;
 274
 275     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 276
 277     if ( $method eq "DESTROY" ) {
 278         return;
 279     }
 280     if ( exists( $self->user->{'attributes'}->{$method} ) ) {
 281         return $self->user->{'attributes'}->{$method};
 282     }
 283     elsif ( $method eq "username" ) {
 284         my $userfield = $self->store->user_field;
 285         my $username  = $self->has_attribute($userfield);
 286         if ($username) {
 287             return $username;
 288         }
 289         else {
 290             Catalyst::Exception->throw( "User is missing the "
 291                     . $userfield
 292                     . " attribute, which should not be possible!" );
 293         }
 294     }
 295     else {
 296         Catalyst::Exception->throw(
 297             "No attribute $method for User " . $self->stringify );
 298     }
 299 }
 300
 301 1;
 302
 303 __END__
 304
 305 =head1 AUTHORS
 306
 307 Adam Jacob <holoway@cpan.org>
 308
 309 Some parts stolen shamelessly and entirely from
 310 L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
 311
 312 Currently maintained by Peter Karman <karman@cpan.org>.
 313
 314 =head1 THANKS
 315
 316 To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
 317
 318 =head1 SEE ALSO
 319
 320 L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
 321
 322 =head1 COPYRIGHT & LICENSE
 323
 324 Copyright (c) 2005 the aforementioned authors. All rights
 325 reserved. This program is free software; you can redistribute
 326 it and/or modify it under the same terms as Perl itself.
 327
 328 =cut
 329