[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.1005';

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

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

=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 ($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;
    my $msg = $self->store->ldap_bind( undef, $self->ldap_entry->dn,
        $self->_ldap_connection_password->() );
    $msg->code && die("Error whilst re-binding as " . $self->ldap_entry->dn
        . " after auth: " . $msg->error . " (" . $msg->code . ")");
    return $self->store;
}

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