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