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