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 use Scalar::Util qw/refaddr/;
  52 use Net::LDAP::Entry;
  53
  54 our $VERSION = '1.015';
  55
  56 BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
  57
  58 use overload '""' => sub { shift->stringify }, fallback => 1;
  59
  60 my %_ldap_connection_passwords; # Store inside-out so that they don't show up
  61                                 # in dumps..
  62
  63 =head1 METHODS
  64
  65 =head2 new($store, $user, $c)
  66
  67 Takes a L<Catalyst::Authentication::Store::LDAP::Backend> object
  68 as $store, and the data structure returned by that class's "get_user"
  69 method as $user.  The final argument is an instance of your application,
  70 which is passed along for those wanting to subclass User and perhaps use
  71 models for fetching data.
  72
  73 Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
  74
  75 =cut
  76
  77 sub new {
  78     my ( $class, $store, $user, $c, $roles ) = @_;
  79
  80     return unless $user;
  81
  82     bless { store => $store, user => $user, _roles => $roles }, $class;
  83 }
  84
  85 =head2 id
  86
  87 Returns the results of the "stringify" method.
  88
  89 =cut
  90
  91 sub id {
  92     my $self = shift;
  93     return $self->stringify;
  94 }
  95
  96 =head2 stringify
  97
  98 Uses the "user_field" configuration option to determine what the "username"
  99 of this object is, and returns it.
 100
 101 If you use the special value "dn" for user_field, it will return the DN
 102 of the L<Net::LDAP::Entry> object.
 103
 104 =cut
 105
 106 sub stringify {
 107     my ($self) = @_;
 108     my $userfield = $self->store->user_field;
 109     $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
 110     if ( $userfield eq "dn" ) {
 111         my ($string) = $self->user->ldap_entry->dn;
 112         return $string;
 113     }
 114     else {
 115         my $val = $self->$userfield;
 116         return ref($val) eq 'ARRAY' ? $val->[0] : $val;
 117     }
 118 }
 119
 120 =head2 supported_features
 121
 122 Returns hashref of features that this Authentication::User subclass supports.
 123
 124 =cut
 125
 126 sub supported_features {
 127     return {
 128         password => { self_check => 1, },
 129         session  => 1,
 130         roles    => { self_check => 0, },
 131     };
 132 }
 133
 134 =head2 check_password($password)
 135
 136 Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
 137 using the bind password supplied in $password.  Returns 1 on a successful
 138 bind, 0 on failure.
 139
 140 =cut
 141
 142 sub check_password {
 143     my ( $self, $password ) = @_;
 144     if ( $self->store->ldap_auth($self->ldap_entry->dn, $password) ) {
 145         # Stash a closure which can be used to retrieve the connection in the users context later.
 146         $_ldap_connection_passwords{refaddr($self)} = $password;
 147         return 1;
 148     }
 149     else {
 150         return 0;
 151     }
 152 }
 153
 154 =head2 roles
 155
 156 Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
 157
 158 =cut
 159
 160 sub roles {
 161     my $self = shift;
 162     $self->{_roles} ||= [$self->store->lookup_roles($self)];
 163     return @{$self->{_roles}};
 164 }
 165
 166 =head2 for_session
 167
 168 Returns the user for persistence in the session depending on the
 169 persist_in_session config option.
 170
 171 =cut
 172
 173 sub for_session {
 174     my $self = shift;
 175
 176     if ( $self->store->persist_in_session eq 'all' ) {
 177         # use the roles accessor to ensure the roles are fetched
 178         return { user => $self->user, _roles => [ $self->roles ] };
 179     }
 180
 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 ( $attribute eq "username" ) {
 230        return $self->user->{'attributes'}->{$self->store->user_field};
 231     }
 232     elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
 233         return $self->user->{'attributes'}->{$attribute};
 234     }
 235     else {
 236         return undef;
 237     }
 238 }
 239
 240 =head2 get
 241
 242 A simple wrapper around has_attribute() to satisfy the Catalyst::Authentication::User API.
 243
 244 =cut
 245
 246 sub get { return shift->has_attribute(@_) }
 247
 248 =head2 get_object
 249
 250 Satisfies the Catalyst::Authentication::User API and returns the contents of the user()
 251 attribute.
 252
 253 =cut
 254
 255 sub get_object { return shift->user }
 256
 257 =head2 ldap_connection
 258
 259 Re-binds to the auth store with the credentials of the user you logged in
 260 as, and returns a L<Net::LDAP> object which you can use to do further queries.
 261
 262 =cut
 263
 264 sub ldap_connection {
 265     my $self = shift;
 266     $self->store->ldap_bind( undef, $self->ldap_entry->dn,
 267         $_ldap_connection_passwords{refaddr($self)} );
 268 }
 269
 270 =head2 AUTOLOADed methods
 271
 272 We automatically map the attributes of the underlying L<Net::LDAP::Entry>
 273 object to read-only accessor methods.  So, if you have an entry that looks
 274 like this one:
 275
 276     dn: cn=adam,ou=users,dc=yourcompany,dc=com
 277     cn: adam
 278     loginShell: /bin/zsh
 279     homeDirectory: /home/adam
 280     gecos: Adam Jacob
 281     gidNumber: 100
 282     uidNumber: 1053
 283     mail: adam@yourcompany.com
 284     uid: adam
 285     givenName: Adam
 286     sn: Jacob
 287     objectClass: inetOrgPerson
 288     objectClass: organizationalPerson
 289     objectClass: Person
 290     objectClass: Top
 291     objectClass: posixAccount
 292
 293 You can call:
 294
 295     $c->user->homedirectory
 296
 297 And you'll get the value of the "homeDirectory" attribute.  Note that
 298 all the AUTOLOADed methods are automatically lower-cased.
 299
 300 =head2 Special Keywords
 301
 302 The highly useful and common method "username" will map to the configured
 303 value of user_field (uid by default.)
 304
 305     $c->user->username == $c->user->uid
 306
 307 =cut
 308
 309 sub DESTROY {
 310     my $self = shift;
 311     # Don't leak passwords..
 312     delete $_ldap_connection_passwords{refaddr($self)};
 313 }
 314
 315 sub can {
 316     my ($self, $method) = @_;
 317
 318     return $self->SUPER::can($method) || do {
 319         return unless $self->has_attribute($method);
 320         return sub { $_[0]->has_attribute($method) };
 321     };
 322 }
 323
 324 sub AUTOLOAD {
 325     my $self = shift;
 326
 327     ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
 328
 329     if ( $method eq "DESTROY" ) {
 330         return;
 331     }
 332
 333     if ( my $attribute = $self->has_attribute($method) ) {
 334         return $attribute;
 335     }
 336     else {
 337         Catalyst::Exception->throw(
 338             "No attribute $method for User " . $self->stringify );
 339     }
 340 }
 341
 342 1;
 343
 344 __END__
 345
 346 =head1 AUTHORS
 347
 348 Adam Jacob <holoway@cpan.org>
 349
 350 Some parts stolen shamelessly and entirely from
 351 L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
 352
 353 Currently maintained by Peter Karman <karman@cpan.org>.
 354
 355 =head1 THANKS
 356
 357 To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
 358
 359 =head1 SEE ALSO
 360
 361 L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
 362
 363 =head1 COPYRIGHT & LICENSE
 364
 365 Copyright (c) 2005 the aforementioned authors. All rights
 366 reserved. This program is free software; you can redistribute
 367 it and/or modify it under the same terms as Perl itself.
 368
 369 =cut
 370