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->login do
  12 it for you.
  13
  14     sub action : Local {
  15         my ( $self, $c ) = @_;
  16         $c->login($c->req->param(username), $c->req->param(password));
  17         $c->log->debug($c->user->username . "is really neat!");
  18     }
  19
  20 If you access just $c->user in a scalar context, it will return the current
  21 username.
  22
  23 =head1 DESCRIPTION
  24
  25 This wraps up an LDAP object and presents a simplified interface to it's
  26 contents.  It uses some AUTOLOAD magic to pass method calls it doesn't
  27 understand through as simple read only accessors for the LDAP entries
  28 various attributes.
  29
  30 It gets grumpy if you ask for an attribute via the AUTOLOAD mechanism
  31 that it doesn't know about.  Avoid that with using "has_attribute",
  32 discussed in more detail below.
  33
  34 You can skip all that and just go straight to the L<Net::LDAP::Entry>
  35 object through the "ldap_entry" method:
  36
  37     my $entry = $c->user->ldap_entry;
  38
  39 It also has support for Roles.
  40
  41 =cut
  42
  43 package Catalyst::Authentication::Store::LDAP::User;
  44 use base qw( Catalyst::Authentication::User Class::Accessor::Fast );
  45
  46 use strict;
  47 use warnings;
  48
  49 our $VERSION = '0.1004';
  50
  51 BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
  52
  53 use overload '""' => sub { shift->stringify }, fallback => 1;
  54
  55 =head1 METHODS
  56
  57 =head2 new($store, $user)
  58
  59 Takes a L<Catalyst::Authentication::Store::LDAP::Backend> object
  60 as $store, and the data structure returned by that class's "get_user"
  61 method as $user.
  62
  63 Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
  64
  65 =cut
  66
  67 sub new {
  68     my ( $class, $store, $user ) = @_;
  69
  70     return unless $user;
  71
  72     bless { store => $store, user => $user, }, $class;
  73 }
  74
  75 =head2 id
  76
  77 Returns the results of the "stringify" method.
  78
  79 =cut
  80
  81 sub id {
  82     my $self = shift;
  83     return $self->stringify;
  84 }
  85
  86 =head2 stringify
  87
  88 Uses the "user_field" configuration option to determine what the "username"
  89 of this object is, and returns it.
  90
  91 If you use the special value "dn" for user_field, it will return the DN
  92 of the L<Net::LDAP::Entry> object.
  93
  94 =cut
  95
  96 sub stringify {
  97     my ($self) = @_;
  98     my $userfield = $self->store->user_field;
  99     $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
 100     if ( $userfield eq "dn" ) {
 101         my ($string) = $self->user->ldap_entry->dn;
 102         return $string;
 103     }
 104     else {
 105         my ($string) = $self->$userfield;
 106         return $string;
 107     }
 108 }
 109
 110 =head2 supported_features
 111
 112 Returns hashref of features that this Authentication::User subclass supports.
 113
 114 =cut
 115
 116 sub supported_features {
 117     return {
 118         password => { self_check => 1, },
 119         session  => 1,
 120         roles    => { self_check => 0, },
 121     };
 122 }
 123
 124 =head2 check_password($password)
 125
 126 Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
 127 using the bind password supplied in $password.  Returns 1 on a successful
 128 bind, 0 on failure.
 129
 130 =cut
 131
 132 sub check_password {
 133     my ( $self, $password ) = @_;
 134     my $ldap
 135         = $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password,
 136         'forauth' );
 137     if ( defined($ldap) ) {
 138         if ($self->store->role_search_as_user) {
 139             # Have to do the role lookup _now_, as this is the only time
 140             # that we have the user's password/ldap bind..
 141             $self->roles($ldap);
 142         }
 143         return 1;
 144     }
 145     else {
 146         return 0;
 147     }
 148 }
 149
 150 =head2 roles
 151
 152 Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
 153
 154 =cut
 155
 156 sub roles {
 157     my $self = shift;
 158     my $ldap = shift;
 159     $self->{_roles} ||= [$self->store->lookup_roles($self, $ldap)];
 160     return @{$self->{_roles}};
 161 }
 162
 163 =head2 for_session
 164
 165 Returns the User object, stringified.
 166
 167 =cut
 168
 169 sub for_session {
 170     my $self = shift;
 171     return $self->stringify;
 172 }
 173
 174 =head2 ldap_entry
 175
 176 Returns the raw ldap_entry.
 177
 178 =cut
 179
 180 sub ldap_entry {
 181     my $self = shift;
 182     return $self->user->{'ldap_entry'};
 183 }
 184
 185 =head2 attributes($type)
 186
 187 Returns an array of attributes present for this user.  If $type is "ashash",
 188 it will return a hash with the attribute names as keys. (And the values of
 189 those attributes as, well, the values of the hash)
 190
 191 =cut
 192
 193 sub attributes {
 194     my ( $self, $type ) = @_;
 195     if ( $type eq "ashash" ) {
 196         return $self->user->{'attributes'};
 197     }
 198     else {
 199         return keys( %{ $self->user->{'attributes'} } );
 200     }
 201 }
 202
 203 =head2 has_attribute
 204
 205 Returns the values for an attribute, or undef if that attribute is not present.
 206 The safest way to get at an attribute.
 207
 208 =cut
 209
 210 sub has_attribute {
 211     my ( $self, $attribute ) = @_;
 212     if ( !defined($attribute) ) {
 213         Catalyst::Exception->throw(
 214             "You must provide an attribute to has_attribute!");
 215     }
 216     if ( $attribute eq "dn" ) {
 217         return $self->ldap_entry->dn;
 218     }
 219     elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
 220         return $self->user->{'attributes'}->{$attribute};
 221     }
 222     else {
 223         return undef;
 224     }
 225 }
 226
 227 =head2 AUTOLOADed methods
 228
 229 We automatically map the attributes of the underlying L<Net::LDAP::Entry>
 230 object to read-only accessor methods.  So, if you have an entry that looks
 231 like this one:
 232
 233     dn: cn=adam,ou=users,dc=yourcompany,dc=com
 234     cn: adam
 235     loginShell: /bin/zsh
 236     homeDirectory: /home/adam
 237     gecos: Adam Jacob
 238     gidNumber: 100
 239     uidNumber: 1053
 240     mail: adam@yourcompany.com
 241     uid: adam
 242     givenName: Adam
 243     sn: Jacob
 244     objectClass: inetOrgPerson
 245     objectClass: organizationalPerson
 246     objectClass: Person
 247     objectClass: Top
 248     objectClass: posixAccount
 249
 250 You can call:
 251
 252     $c->user->homedirectory
 253
 254 And you'll get the value of the "homeDirectory" attribute.  Note that
 255 all the AUTOLOADed methods are automatically lower-cased.
 256
 257 =head2 Special Keywords
 258
 259 The highly useful and common method "username" will map to the configured
 260 value of user_field (uid by default.)
 261
 262     $c->user->username == $c->user->uid
 263
 264 =cut
 265
 266 sub AUTOLOAD {
 267     my $self = shift;
 268
 269     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 270
 271     if ( $method eq "DESTROY" ) {
 272         return;
 273     }
 274     if ( exists( $self->user->{'attributes'}->{$method} ) ) {
 275         return $self->user->{'attributes'}->{$method};
 276     }
 277     elsif ( $method eq "username" ) {
 278         my $userfield = $self->store->user_field;
 279         my $username  = $self->has_attribute($userfield);
 280         if ($username) {
 281             return $username;
 282         }
 283         else {
 284             Catalyst::Exception->throw( "User is missing the "
 285                     . $userfield
 286                     . " attribute, which should not be possible!" );
 287         }
 288     }
 289     else {
 290         Catalyst::Exception->throw(
 291             "No attribute $method for User " . $self->stringify );
 292     }
 293 }
 294
 295 1;
 296
 297 __END__
 298
 299 =head1 AUTHORS
 300
 301 Adam Jacob <holoway@cpan.org>
 302
 303 Some parts stolen shamelessly and entirely from
 304 L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
 305
 306 Currently maintained by Peter Karman <karman@cpan.org>.
 307
 308 =head1 THANKS
 309
 310 To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
 311
 312 =head1 SEE ALSO
 313
 314 L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
 315
 316 =head1 COPYRIGHT & LICENSE
 317
 318 Copyright (c) 2005 the aforementioned authors. All rights
 319 reserved. This program is free software; you can redistribute
 320 it and/or modify it under the same terms as Perl itself.
 321
 322 =cut
 323