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.1005';
  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, $c)
  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.  The final argument is an instance of your application,
  65 which is passed along for those wanting to subclass User and perhaps use
  66 models for fetching data.
  67
  68 Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
  69
  70 =cut
  71
  72 sub new {
  73     my ( $class, $store, $user, $c ) = @_;
  74
  75     return unless $user;
  76
  77     bless { store => $store, user => $user, }, $class;
  78 }
  79
  80 =head2 id
  81
  82 Returns the results of the "stringify" method.
  83
  84 =cut
  85
  86 sub id {
  87     my $self = shift;
  88     return $self->stringify;
  89 }
  90
  91 =head2 stringify
  92
  93 Uses the "user_field" configuration option to determine what the "username"
  94 of this object is, and returns it.
  95
  96 If you use the special value "dn" for user_field, it will return the DN
  97 of the L<Net::LDAP::Entry> object.
  98
  99 =cut
 100
 101 sub stringify {
 102     my ($self) = @_;
 103     my $userfield = $self->store->user_field;
 104     $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
 105     if ( $userfield eq "dn" ) {
 106         my ($string) = $self->user->ldap_entry->dn;
 107         return $string;
 108     }
 109     else {
 110         my ($string) = $self->$userfield;
 111         return $string;
 112     }
 113 }
 114
 115 =head2 supported_features
 116
 117 Returns hashref of features that this Authentication::User subclass supports.
 118
 119 =cut
 120
 121 sub supported_features {
 122     return {
 123         password => { self_check => 1, },
 124         session  => 1,
 125         roles    => { self_check => 0, },
 126     };
 127 }
 128
 129 =head2 check_password($password)
 130
 131 Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
 132 using the bind password supplied in $password.  Returns 1 on a successful
 133 bind, 0 on failure.
 134
 135 =cut
 136
 137 sub check_password {
 138     my ( $self, $password ) = @_;
 139     my $ldap
 140         = $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password,
 141         'forauth' );
 142     if ( defined($ldap) ) {
 143         if ($self->store->role_search_as_user) {
 144             # FIXME - This can be removed and made to use the code below..
 145             # Have to do the role lookup _now_, as this is the only time
 146             # that we have the user's password/ldap bind..
 147             $self->roles($ldap);
 148         }
 149         # Stash a closure which can be used to retrieve the connection in the users context later.
 150         $self->_ldap_connection( sub { $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password ) } );
 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 AUTOLOADed methods
 236
 237 We automatically map the attributes of the underlying L<Net::LDAP::Entry>
 238 object to read-only accessor methods.  So, if you have an entry that looks
 239 like this one:
 240
 241     dn: cn=adam,ou=users,dc=yourcompany,dc=com
 242     cn: adam
 243     loginShell: /bin/zsh
 244     homeDirectory: /home/adam
 245     gecos: Adam Jacob
 246     gidNumber: 100
 247     uidNumber: 1053
 248     mail: adam@yourcompany.com
 249     uid: adam
 250     givenName: Adam
 251     sn: Jacob
 252     objectClass: inetOrgPerson
 253     objectClass: organizationalPerson
 254     objectClass: Person
 255     objectClass: Top
 256     objectClass: posixAccount
 257
 258 You can call:
 259
 260     $c->user->homedirectory
 261
 262 And you'll get the value of the "homeDirectory" attribute.  Note that
 263 all the AUTOLOADed methods are automatically lower-cased.
 264
 265 =head2 Special Keywords
 266
 267 The highly useful and common method "username" will map to the configured
 268 value of user_field (uid by default.)
 269
 270     $c->user->username == $c->user->uid
 271
 272 =cut
 273
 274 sub AUTOLOAD {
 275     my $self = shift;
 276
 277     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 278
 279     if ( $method eq "DESTROY" ) {
 280         return;
 281     }
 282     if ( exists( $self->user->{'attributes'}->{$method} ) ) {
 283         return $self->user->{'attributes'}->{$method};
 284     }
 285     elsif ( $method eq "username" ) {
 286         my $userfield = $self->store->user_field;
 287         my $username  = $self->has_attribute($userfield);
 288         if ($username) {
 289             return $username;
 290         }
 291         else {
 292             Catalyst::Exception->throw( "User is missing the "
 293                     . $userfield
 294                     . " attribute, which should not be possible!" );
 295         }
 296     }
 297     else {
 298         Catalyst::Exception->throw(
 299             "No attribute $method for User " . $self->stringify );
 300     }
 301 }
 302
 303 1;
 304
 305 __END__
 306
 307 =head1 AUTHORS
 308
 309 Adam Jacob <holoway@cpan.org>
 310
 311 Some parts stolen shamelessly and entirely from
 312 L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
 313
 314 Currently maintained by Peter Karman <karman@cpan.org>.
 315
 316 =head1 THANKS
 317
 318 To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
 319
 320 =head1 SEE ALSO
 321
 322 L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
 323
 324 =head1 COPYRIGHT & LICENSE
 325
 326 Copyright (c) 2005 the aforementioned authors. All rights
 327 reserved. This program is free software; you can redistribute
 328 it and/or modify it under the same terms as Perl itself.
 329
 330 =cut
 331