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