[catagits/Catalyst-Authentication-Store-LDAP.git] / lib / Catalyst / Authentication / Store / LDAP / User.pm


=pod

=head1 NAME

Catalyst::Authentication::Store::LDAP::User
 - A User object representing an LDAP object. 

=head1 SYNOPSIS

You should be creating these objects through L<Catalyst::Authentication::Store::LDAP::Backend>'s "get_user" method, or just letting $c->authenticate do
it for you.

    sub action : Local {
        my ( $self, $c ) = @_;
        $c->authenticate({
            id => $c->req->param(username),
            password => $c->req->param(password)
        );
        $c->log->debug($c->user->username . "is really neat!");
    }

If you access just $c->user in a scalar context, it will return the current
username.

=head1 DESCRIPTION

This wraps up an LDAP object and presents a simplified interface to it's
contents.  It uses some AUTOLOAD magic to pass method calls it doesn't
understand through as simple read only accessors for the LDAP entries
various attributes.  

It gets grumpy if you ask for an attribute via the AUTOLOAD mechanism
that it doesn't know about.  Avoid that with using "has_attribute", 
discussed in more detail below.

You can skip all that and just go straight to the L<Net::LDAP::Entry>
object through the "ldap_entry" method:

    my $entry = $c->user->ldap_entry;

It also has support for Roles.

=cut

package Catalyst::Authentication::Store::LDAP::User;
use base qw( Catalyst::Authentication::User Class::Accessor::Fast );

use strict;
use warnings;
use Scalar::Util qw/refaddr/;

our $VERSION = '1.014';

BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }

use overload '""' => sub { shift->stringify }, fallback => 1;

my %_ldap_connection_passwords; # Store inside-out so that they don't show up
                                # in dumps..

=head1 METHODS

=head2 new($store, $user, $c)

Takes a L<Catalyst::Authentication::Store::LDAP::Backend> object
as $store, and the data structure returned by that class's "get_user"
method as $user.  The final argument is an instance of your application,
which is passed along for those wanting to subclass User and perhaps use
models for fetching data.

Returns a L<Catalyst::Authentication::Store::LDAP::User> object.

=cut

sub new {
    my ( $class, $store, $user, $c ) = @_;

    return unless $user;

    bless { store => $store, user => $user, }, $class;
}

=head2 id

Returns the results of the "stringify" method.

=cut

sub id {
    my $self = shift;
    return $self->stringify;
}

=head2 stringify

Uses the "user_field" configuration option to determine what the "username"
of this object is, and returns it.

If you use the special value "dn" for user_field, it will return the DN
of the L<Net::LDAP::Entry> object.

=cut

sub stringify {
    my ($self) = @_;
    my $userfield = $self->store->user_field;
    $userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
    if ( $userfield eq "dn" ) {
        my ($string) = $self->user->ldap_entry->dn;
        return $string;
    }
    else {
        my $val = $self->$userfield;
        return ref($val) eq 'ARRAY' ? $val->[0] : $val;
    }
}

=head2 supported_features

Returns hashref of features that this Authentication::User subclass supports.

=cut

sub supported_features {
    return {
        password => { self_check => 1, },
        session  => 1,
        roles    => { self_check => 0, },
    };
}

=head2 check_password($password)

Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
using the bind password supplied in $password.  Returns 1 on a successful
bind, 0 on failure.

=cut

sub check_password {
    my ( $self, $password ) = @_;
    my $ldap
        = $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password,
        'forauth' );
    if ( defined($ldap) ) {
        if ($self->store->role_search_as_user) {
            # FIXME - This can be removed and made to use the code below..
            # Have to do the role lookup _now_, as this is the only time
            # that we have the user's password/ldap bind..
            $self->roles($ldap);
        }
        # Stash a closure which can be used to retrieve the connection in the users context later.
        $_ldap_connection_passwords{refaddr($self)} = $password;
        return 1;
    }
    else {
        return 0;
    }
}

=head2 roles

Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.

=cut

sub roles {
    my $self = shift;
    my $ldap = shift;
    $self->{_roles} ||= [$self->store->lookup_roles($self, $ldap)];
    return @{$self->{_roles}};
}

=head2 for_session

Returns the User object, stringified.

=cut

sub for_session {
    my $self = shift;
    return $self->stringify;
}

=head2 ldap_entry

Returns the raw ldap_entry. 

=cut

sub ldap_entry {
    my $self = shift;
    return $self->user->{'ldap_entry'};
}

=head2 attributes($type)

Returns an array of attributes present for this user.  If $type is "ashash",
it will return a hash with the attribute names as keys. (And the values of
those attributes as, well, the values of the hash)

=cut

sub attributes {
    my ( $self, $type ) = @_;
    if ( $type eq "ashash" ) {
        return $self->user->{'attributes'};
    }
    else {
        return keys( %{ $self->user->{'attributes'} } );
    }
}

=head2 has_attribute

Returns the values for an attribute, or undef if that attribute is not present.
The safest way to get at an attribute. 

=cut

sub has_attribute {
    my ( $self, $attribute ) = @_;
    if ( !defined($attribute) ) {
        Catalyst::Exception->throw(
            "You must provide an attribute to has_attribute!");
    }
    if ( $attribute eq "dn" ) {
        return $self->ldap_entry->dn;
    }
    elsif ( $attribute eq "username" ) {
       return $self->user->{'attributes'}->{$self->store->user_field};
    }
    elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
        return $self->user->{'attributes'}->{$attribute};
    }
    else {
        return undef;
    }
}

=head2 get

A simple wrapper around has_attribute() to satisfy the Catalyst::Authentication::User API.

=cut

sub get { return shift->has_attribute(@_) }

=head2 get_object

Satisfies the Catalyst::Authentication::User API and returns the contents of the user()
attribute.

=cut

sub get_object { return shift->user }

=head2 ldap_connection

Re-binds to the auth store with the credentials of the user you logged in
as, and returns a L<Net::LDAP> object which you can use to do further queries.

=cut

sub ldap_connection {
    my $self = shift;
    $self->store->ldap_bind( undef, $self->ldap_entry->dn,
        $_ldap_connection_passwords{refaddr($self)} );
}

=head2 AUTOLOADed methods

We automatically map the attributes of the underlying L<Net::LDAP::Entry>
object to read-only accessor methods.  So, if you have an entry that looks
like this one:

    dn: cn=adam,ou=users,dc=yourcompany,dc=com
    cn: adam
    loginShell: /bin/zsh
    homeDirectory: /home/adam
    gecos: Adam Jacob
    gidNumber: 100
    uidNumber: 1053
    mail: adam@yourcompany.com
    uid: adam
    givenName: Adam
    sn: Jacob
    objectClass: inetOrgPerson
    objectClass: organizationalPerson
    objectClass: Person
    objectClass: Top
    objectClass: posixAccount

You can call:

    $c->user->homedirectory

And you'll get the value of the "homeDirectory" attribute.  Note that
all the AUTOLOADed methods are automatically lower-cased. 

=head2 Special Keywords

The highly useful and common method "username" will map to the configured
value of user_field (uid by default.) 

    $c->user->username == $c->user->uid

=cut

sub DESTROY {
    my $self = shift;
    # Don't leak passwords..
    delete $_ldap_connection_passwords{refaddr($self)};
}

sub can {
    my ($self, $method) = @_;

    return $self->SUPER::can($method) || do {
        return unless $self->has_attribute($method);
        return sub { $_[0]->has_attribute($method) };
    };
}

sub AUTOLOAD {
    my $self = shift;

    ( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );

    if ( $method eq "DESTROY" ) {
        return;
    }

    if ( my $attribute = $self->has_attribute($method) ) {
        return $attribute;
    }
    else {
        Catalyst::Exception->throw(
            "No attribute $method for User " . $self->stringify );
    }
}

1;

__END__

=head1 AUTHORS

Adam Jacob <holoway@cpan.org>

Some parts stolen shamelessly and entirely from
L<Catalyst::Plugin::Authentication::Store::Htpasswd>. 

Currently maintained by Peter Karman <karman@cpan.org>.

=head1 THANKS

To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)

=head1 SEE ALSO

L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2005 the aforementioned authors. All rights
reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

=cut
Commit	Line	Data
f66d606b	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
afb8e81c	11	You should be creating these objects through L<Catalyst::Authentication::Store::LDAP::Backend>'s "get_user" method, or just letting $c->authenticate do
f66d606b	12	it for you.
	13
	14	sub action : Local {
	15	my ( $self, $c ) = @_;
afb8e81c	16	$c->authenticate({
	17	id => $c->req->param(username),
	18	password => $c->req->param(password)
	19	);
f66d606b	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;
8fe890e6	51	use Scalar::Util qw/refaddr/;
f66d606b	52
62534b1b	53	our $VERSION = '1.014';
f66d606b	54
8fe890e6	55	BEGIN { __PACKAGE__->mk_accessors(qw/user store/) }
f66d606b	56
	57	use overload '""' => sub { shift->stringify }, fallback => 1;
	58
8fe890e6	59	my %_ldap_connection_passwords; # Store inside-out so that they don't show up
	60	# in dumps..
	61
f66d606b	62	=head1 METHODS
f66d606b	63
52a972a4	64	=head2 new($store, $user, $c)
f66d606b	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"
52a972a4	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.
f66d606b	71
	72	Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
	73
	74	=cut
	75
	76	sub new {
52a972a4	77	my ( $class, $store, $user, $c ) = @_;
f66d606b	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 {
394e2cec	114	my $val = $self->$userfield;
394e2cec	115	return ref($val) eq 'ARRAY' ? $val->[0] : $val;
f66d606b	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) ) {
405489b5	147	if ($self->store->role_search_as_user) {
57e643d2	148	# FIXME - This can be removed and made to use the code below..
405489b5	149	# Have to do the role lookup _now_, as this is the only time
	150	# that we have the user's password/ldap bind..
	151	$self->roles($ldap);
	152	}
57e643d2	153	# Stash a closure which can be used to retrieve the connection in the users context later.
8fe890e6	154	$_ldap_connection_passwords{refaddr($self)} = $password;
f66d606b	155	return 1;
	156	}
	157	else {
	158	return 0;
	159	}
	160	}
	161
	162	=head2 roles
	163
	164	Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
	165
	166	=cut
	167
	168	sub roles {
	169	my $self = shift;
405489b5	170	my $ldap = shift;
	171	$self->{_roles} \|\|= [$self->store->lookup_roles($self, $ldap)];
	172	return @{$self->{_roles}};
f66d606b	173	}
	174
	175	=head2 for_session
	176
	177	Returns the User object, stringified.
	178
	179	=cut
	180
	181	sub for_session {
	182	my $self = shift;
	183	return $self->stringify;
	184	}
	185
	186	=head2 ldap_entry
	187
	188	Returns the raw ldap_entry.
	189
	190	=cut
	191
	192	sub ldap_entry {
	193	my $self = shift;
	194	return $self->user->{'ldap_entry'};
	195	}
	196
	197	=head2 attributes($type)
	198
	199	Returns an array of attributes present for this user. If $type is "ashash",
	200	it will return a hash with the attribute names as keys. (And the values of
	201	those attributes as, well, the values of the hash)
	202
	203	=cut
	204
	205	sub attributes {
	206	my ( $self, $type ) = @_;
	207	if ( $type eq "ashash" ) {
	208	return $self->user->{'attributes'};
	209	}
	210	else {
	211	return keys( %{ $self->user->{'attributes'} } );
	212	}
	213	}
	214
	215	=head2 has_attribute
	216
	217	Returns the values for an attribute, or undef if that attribute is not present.
	218	The safest way to get at an attribute.
	219
	220	=cut
	221
	222	sub has_attribute {
	223	my ( $self, $attribute ) = @_;
	224	if ( !defined($attribute) ) {
	225	Catalyst::Exception->throw(
	226	"You must provide an attribute to has_attribute!");
	227	}
	228	if ( $attribute eq "dn" ) {
	229	return $self->ldap_entry->dn;
	230	}
a4427384	231	elsif ( $attribute eq "username" ) {
	232	return $self->user->{'attributes'}->{$self->store->user_field};
	233	}
f66d606b	234	elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
	235	return $self->user->{'attributes'}->{$attribute};
	236	}
	237	else {
	238	return undef;
	239	}
	240	}
	241
57d476f1	242	=head2 get
	243
	244	A simple wrapper around has_attribute() to satisfy the Catalyst::Authentication::User API.
	245
	246	=cut
	247
	248	sub get { return shift->has_attribute(@_) }
	249
	250	=head2 get_object
	251
	252	Satisfies the Catalyst::Authentication::User API and returns the contents of the user()
	253	attribute.
	254
	255	=cut
	256
	257	sub get_object { return shift->user }
	258
da0d62e4	259	=head2 ldap_connection
	260
	261	Re-binds to the auth store with the credentials of the user you logged in
	262	as, and returns a L<Net::LDAP> object which you can use to do further queries.
	263
	264	=cut
	265
	266	sub ldap_connection {
	267	my $self = shift;
89ab2886	268	$self->store->ldap_bind( undef, $self->ldap_entry->dn,
8fe890e6	269	$_ldap_connection_passwords{refaddr($self)} );
da0d62e4	270	}
da0d62e4	271
f66d606b	272	=head2 AUTOLOADed methods
	273
	274	We automatically map the attributes of the underlying L<Net::LDAP::Entry>
	275	object to read-only accessor methods. So, if you have an entry that looks
	276	like this one:
	277
	278	dn: cn=adam,ou=users,dc=yourcompany,dc=com
	279	cn: adam
	280	loginShell: /bin/zsh
	281	homeDirectory: /home/adam
	282	gecos: Adam Jacob
	283	gidNumber: 100
	284	uidNumber: 1053
	285	mail: adam@yourcompany.com
	286	uid: adam
	287	givenName: Adam
	288	sn: Jacob
	289	objectClass: inetOrgPerson
	290	objectClass: organizationalPerson
	291	objectClass: Person
	292	objectClass: Top
	293	objectClass: posixAccount
	294
	295	You can call:
	296
	297	$c->user->homedirectory
	298
	299	And you'll get the value of the "homeDirectory" attribute. Note that
	300	all the AUTOLOADed methods are automatically lower-cased.
	301
	302	=head2 Special Keywords
	303
	304	The highly useful and common method "username" will map to the configured
	305	value of user_field (uid by default.)
	306
	307	$c->user->username == $c->user->uid
	308
	309	=cut
	310
8fe890e6	311	sub DESTROY {
	312	my $self = shift;
	313	# Don't leak passwords..
	314	delete $_ldap_connection_passwords{refaddr($self)};
	315	}
	316
ec21cfdc	317	sub can {
	318	my ($self, $method) = @_;
	319
	320	return $self->SUPER::can($method) \|\| do {
	321	return unless $self->has_attribute($method);
	322	return sub { $_[0]->has_attribute($method) };
	323	};
	324	}
	325
f66d606b	326	sub AUTOLOAD {
	327	my $self = shift;
	328
	329	( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
	330
	331	if ( $method eq "DESTROY" ) {
	332	return;
	333	}
a4427384	334
	335	if ( my $attribute = $self->has_attribute($method) ) {
	336	return $attribute;
f66d606b	337	}
	338	else {
	339	Catalyst::Exception->throw(
	340	"No attribute $method for User " . $self->stringify );
	341	}
	342	}
	343
	344	1;
	345
	346	__END__
	347
	348	=head1 AUTHORS
	349
	350	Adam Jacob <holoway@cpan.org>
	351
	352	Some parts stolen shamelessly and entirely from
	353	L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
	354
	355	Currently maintained by Peter Karman <karman@cpan.org>.
	356
	357	=head1 THANKS
	358
	359	To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
	360
	361	=head1 SEE ALSO
	362
	363	L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
	364
	365	=head1 COPYRIGHT & LICENSE
	366
	367	Copyright (c) 2005 the aforementioned authors. All rights
	368	reserved. This program is free software; you can redistribute
	369	it and/or modify it under the same terms as Perl itself.
	370
	371	=cut
	372