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