[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;

our $VERSION = '0.1004';

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

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

=head1 METHODS

=head2 new($store, $user)

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.

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

=cut

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

    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 ($string) = $self->$userfield;
        return $string;
    }
}

=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.
        $self->_ldap_connection_password( sub { $password } ); # Close over
            # password to try to ensure it doesn't come out in debug dumps
            # or get serialized into sessions etc..
        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 ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
        return $self->user->{'attributes'}->{$attribute};
    }
    else {
        return undef;
    }
}

=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,
        $self->_ldap_connection_password->() );
}

=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 AUTOLOAD {
    my $self = shift;

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

    if ( $method eq "DESTROY" ) {
        return;
    }
    if ( exists( $self->user->{'attributes'}->{$method} ) ) {
        return $self->user->{'attributes'}->{$method};
    }
    elsif ( $method eq "username" ) {
        my $userfield = $self->store->user_field;
        my $username  = $self->has_attribute($userfield);
        if ($username) {
            return $username;
        }
        else {
            Catalyst::Exception->throw( "User is missing the "
                    . $userfield
                    . " attribute, which should not be possible!" );
        }
    }
    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;
	51
405489b5	52	our $VERSION = '0.1004';
f66d606b	53
da0d62e4	54	BEGIN { __PACKAGE__->mk_accessors(qw/user store _ldap_connection_password/) }
f66d606b	55
	56	use overload '""' => sub { shift->stringify }, fallback => 1;
	57
	58	=head1 METHODS
	59
	60	=head2 new($store, $user)
	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.
	65
	66	Returns a L<Catalyst::Authentication::Store::LDAP::User> object.
	67
	68	=cut
	69
	70	sub new {
	71	my ( $class, $store, $user ) = @_;
	72
	73	return unless $user;
	74
	75	bless { store => $store, user => $user, }, $class;
	76	}
	77
	78	=head2 id
	79
	80	Returns the results of the "stringify" method.
	81
	82	=cut
	83
	84	sub id {
	85	my $self = shift;
	86	return $self->stringify;
	87	}
	88
	89	=head2 stringify
	90
	91	Uses the "user_field" configuration option to determine what the "username"
	92	of this object is, and returns it.
	93
	94	If you use the special value "dn" for user_field, it will return the DN
	95	of the L<Net::LDAP::Entry> object.
	96
	97	=cut
	98
	99	sub stringify {
	100	my ($self) = @_;
	101	my $userfield = $self->store->user_field;
	102	$userfield = $$userfield[0] if ref $userfield eq 'ARRAY';
	103	if ( $userfield eq "dn" ) {
	104	my ($string) = $self->user->ldap_entry->dn;
	105	return $string;
	106	}
	107	else {
	108	my ($string) = $self->$userfield;
	109	return $string;
	110	}
	111	}
	112
	113	=head2 supported_features
	114
	115	Returns hashref of features that this Authentication::User subclass supports.
	116
	117	=cut
	118
119	sub supported_features {
120	return {
121	password => { self_check => 1, },
122	session => 1,
123	roles => { self_check => 0, },
124	};
125	}
126
127	=head2 check_password($password)
128
129	Bind's to the directory as the DN of the internal L<Net::LDAP::Entry> object,
130	using the bind password supplied in $password. Returns 1 on a successful
131	bind, 0 on failure.
132
133	=cut
134
135	sub check_password {
136	my ( $self, $password ) = @_;
137	my $ldap
138	= $self->store->ldap_bind( undef, $self->ldap_entry->dn, $password,
139	'forauth' );
140	if ( defined($ldap) ) {
405489b5	141	if ($self->store->role_search_as_user) {
57e643d2	142	# FIXME - This can be removed and made to use the code below..
405489b5	143	# Have to do the role lookup _now_, as this is the only time
	144	# that we have the user's password/ldap bind..
	145	$self->roles($ldap);
	146	}
57e643d2	147	# Stash a closure which can be used to retrieve the connection in the users context later.
da0d62e4	148	$self->_ldap_connection_password( sub { $password } ); # Close over
	149	# password to try to ensure it doesn't come out in debug dumps
	150	# or get serialized into sessions etc..
f66d606b	151	return 1;
	152	}
	153	else {
	154	return 0;
	155	}
	156	}
	157
	158	=head2 roles
	159
	160	Returns the results of L<Catalyst::Authentication::Store::LDAP::Backend>'s "lookup_roles" method, an array of roles that are valid for this user.
	161
	162	=cut
	163
	164	sub roles {
	165	my $self = shift;
405489b5	166	my $ldap = shift;
	167	$self->{_roles} \|\|= [$self->store->lookup_roles($self, $ldap)];
	168	return @{$self->{_roles}};
f66d606b	169	}
	170
	171	=head2 for_session
	172
	173	Returns the User object, stringified.
	174
	175	=cut
	176
	177	sub for_session {
	178	my $self = shift;
	179	return $self->stringify;
	180	}
	181
	182	=head2 ldap_entry
	183
	184	Returns the raw ldap_entry.
	185
	186	=cut
	187
	188	sub ldap_entry {
	189	my $self = shift;
	190	return $self->user->{'ldap_entry'};
	191	}
	192
	193	=head2 attributes($type)
	194
	195	Returns an array of attributes present for this user. If $type is "ashash",
	196	it will return a hash with the attribute names as keys. (And the values of
	197	those attributes as, well, the values of the hash)
	198
	199	=cut
	200
	201	sub attributes {
	202	my ( $self, $type ) = @_;
	203	if ( $type eq "ashash" ) {
	204	return $self->user->{'attributes'};
	205	}
	206	else {
	207	return keys( %{ $self->user->{'attributes'} } );
	208	}
	209	}
	210
	211	=head2 has_attribute
	212
	213	Returns the values for an attribute, or undef if that attribute is not present.
	214	The safest way to get at an attribute.
	215
	216	=cut
	217
	218	sub has_attribute {
	219	my ( $self, $attribute ) = @_;
	220	if ( !defined($attribute) ) {
	221	Catalyst::Exception->throw(
	222	"You must provide an attribute to has_attribute!");
	223	}
	224	if ( $attribute eq "dn" ) {
	225	return $self->ldap_entry->dn;
	226	}
	227	elsif ( exists( $self->user->{'attributes'}->{$attribute} ) ) {
	228	return $self->user->{'attributes'}->{$attribute};
	229	}
	230	else {
	231	return undef;
	232	}
233	}
234
da0d62e4	235	=head2 ldap_connection
	236
	237	Re-binds to the auth store with the credentials of the user you logged in
	238	as, and returns a L<Net::LDAP> object which you can use to do further queries.
	239
	240	=cut
	241
	242	sub ldap_connection {
	243	my $self = shift;
89ab2886	244	$self->store->ldap_bind( undef, $self->ldap_entry->dn,
da0d62e4	245	$self->_ldap_connection_password->() );
da0d62e4	246	}
da0d62e4	247
f66d606b	248	=head2 AUTOLOADed methods
	249
	250	We automatically map the attributes of the underlying L<Net::LDAP::Entry>
	251	object to read-only accessor methods. So, if you have an entry that looks
	252	like this one:
	253
	254	dn: cn=adam,ou=users,dc=yourcompany,dc=com
	255	cn: adam
	256	loginShell: /bin/zsh
	257	homeDirectory: /home/adam
	258	gecos: Adam Jacob
	259	gidNumber: 100
	260	uidNumber: 1053
	261	mail: adam@yourcompany.com
	262	uid: adam
	263	givenName: Adam
	264	sn: Jacob
	265	objectClass: inetOrgPerson
	266	objectClass: organizationalPerson
	267	objectClass: Person
	268	objectClass: Top
	269	objectClass: posixAccount
	270
	271	You can call:
	272
	273	$c->user->homedirectory
	274
	275	And you'll get the value of the "homeDirectory" attribute. Note that
	276	all the AUTOLOADed methods are automatically lower-cased.
	277
	278	=head2 Special Keywords
	279
	280	The highly useful and common method "username" will map to the configured
	281	value of user_field (uid by default.)
	282
	283	$c->user->username == $c->user->uid
	284
	285	=cut
	286
	287	sub AUTOLOAD {
	288	my $self = shift;
	289
	290	( my $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
	291
	292	if ( $method eq "DESTROY" ) {
	293	return;
	294	}
	295	if ( exists( $self->user->{'attributes'}->{$method} ) ) {
	296	return $self->user->{'attributes'}->{$method};
	297	}
	298	elsif ( $method eq "username" ) {
	299	my $userfield = $self->store->user_field;
	300	my $username = $self->has_attribute($userfield);
	301	if ($username) {
	302	return $username;
	303	}
	304	else {
	305	Catalyst::Exception->throw( "User is missing the "
	306	. $userfield
	307	. " attribute, which should not be possible!" );
	308	}
	309	}
	310	else {
	311	Catalyst::Exception->throw(
312	"No attribute $method for User " . $self->stringify );
313	}
314	}
315
316	1;
317
318	__END__
319
320	=head1 AUTHORS
321
322	Adam Jacob <holoway@cpan.org>
323
324	Some parts stolen shamelessly and entirely from
325	L<Catalyst::Plugin::Authentication::Store::Htpasswd>.
326
327	Currently maintained by Peter Karman <karman@cpan.org>.
328
329	=head1 THANKS
330
331	To nothingmuch, ghenry, castaway and the rest of #catalyst for the help. :)
332
333	=head1 SEE ALSO
334
335	L<Catalyst::Authentication::Store::LDAP>, L<Catalyst::Authentication::Store::LDAP::Backend>, L<Catalyst::Plugin::Authentication>, L<Net::LDAP>
336
337	=head1 COPYRIGHT & LICENSE
338
339	Copyright (c) 2005 the aforementioned authors. All rights
340	reserved. This program is free software; you can redistribute
341	it and/or modify it under the same terms as Perl itself.
342
343	=cut
344