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