path: root/lib/CatDap/Controller/user.pm

package CatDap::Controller::user;
use Moose;
use namespace::autoclean;
use Net::LDAP;
use Net::LDAP::Schema;
use Net::LDAP::Extension::SetPassword;
use Net::LDAP::Control::PasswordPolicy 0.02;
use Crypt::CBC;
use Data::Dumper;

BEGIN {extends 'Catalyst::Controller'; }

=head1 NAME

CatDap::Controller::user - Catalyst Controller

=head1 DESCRIPTION

Catalyst Controller.

=head1 METHODS

=cut

=head2 auto

Ensure the user is logged in. In order to bind as the user, we use
CatDap::Model::User, which uses Catalyst::Model::LDAP::FromAuthentication,
which effectively requires calling $c->authenticate on every request.

To do this, we keep the password, encrypted with blowfish, using the
(for now), first 3 octets of IPv4 request address and the session id as the key.

So, if the user does "not exist", we authenticate them, if it succeeds we encrypt
the password and store it in the session.

If the user is logged in, we get the encrypted password from the session, decrypt
it (we need to handle failure to decrypt it better)

=cut

sub auto : Private {
    my ( $self, $c ) = @_;
	my $cipher;
	my $password;
	my $mesg;
	my $dn;
	my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
	if (! defined $c->user) {
		$c->log->info("No session, logging user in");
		if (! $c->authenticate({ username => $c->req->param('username'),
					password => $c->req->param('password') || $c->req->param('key')}) ) {
			#TODO: ppolicy ....
			$c->stash(errors => ['Incorrect username or password']);
			$c->stash(template => 'index.tt');
			$c->forward('/index');
			$c->detach;
		} else {
			#if (defined $c->user->pwdReset) {
			#	$c->res->redirect('/user');
			#}
			#$c->persist_user;
			$c->log->info('Logging user in to LDAP');
			$cipher = Crypt::CBC->new( -key    => $keyprefix . $c->sessionid,
				-cipher => 'Blowfish'
			) or die $!;
			$c->session->{enc_password} = $cipher->encrypt($c->req->param('password') || $c->req->param('key'));
			$c->session->{dn} = $c->user->ldap_entry->dn;
			$c->session->{user} = $c->req->param('username');
			$password = $c->req->param('password') || $c->req->param('key');
			return 1;
		}

	} else {
		$cipher = Crypt::CBC->new( -key    => $keyprefix . $c->sessionid,
			-cipher => 'Blowfish'
		) or die $!;
		$password = $cipher->decrypt($c->session->{enc_password});
		$c->log->info("Re-authenticating user " . $c->session->{user});
		$c->authenticate({username => $c->session->{user},password => $password});
		$c->log->info($@) if $@;
		return 1;
	}

}

=head2 index

=cut

sub index :Path :Args(0) {
	my ( $self, $c ) = @_;
	my $cipher;
	my $password;
	my $mesg;
	my $dn;

	if (not defined $c->user ) {
		$c->stash(template => 'index.tt');
		$c->forward('/index');
		$c->detach;
	}
	my $schemaldap = Net::LDAP->new(${$c->config}{'Model::Proxy'}{'host'}) or warn "LDAP bind failed: $!";
	$schemaldap->start_tls if ${$c->config}{'Model::Proxy'}{'start_tls'};
	$schemaldap->bind;
	my $schema = $schemaldap->schema or die ("Searching schema failed: $!");
	my $attrdef;

	my $user = $c->user->username;
	my $entry;
	$c->log->info("Searching for user $user");
	$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
	$entry = $mesg->entry;
	my %mods;
	my %params = %{$c->req->parameters};
	my $update = 0;
	foreach my $req (keys %params) {
		next if $req !~ /(.+)_new/;
		my $attrname = $1;
		next if $params{$attrname . '_new'} eq $params{$attrname . '_old'};
		$c->log->info("Received update request for attribute $attrname");
		$update = 1;
		$attrdef = $schema->attribute($attrname) or die ("getting schema failed: $!");
		if ($$attrdef{'single-value'}) {
			$entry->replace($attrname => $params{$attrname . '_new' }) or $c->log->info($!);
		} else {
			$entry->delete($attrname => $params{$attrname . '_old'});
			$entry->add($attrname => $params{$attrname . '_new'});
		}
		if ($update) {
			$mesg = $entry->update;
			push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
		}
	}


	$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
	$c->log->info($mesg->error) if $mesg->code;
	$entry = $mesg->entry;
	$c->log->info($mesg->error) if $mesg->code;

	my @values;
	my @attributes = $entry->attributes;
	my @may;
	my @addable_attrs = @attributes;
	my @ocs;
	my @must;
	@ocs = $entry->get_value("objectClass");
	foreach my $oc (@ocs) {
		foreach my $attr ($schema->must($oc)) {
			push @must,$$attr{'name'} if not grep /$$attr{'name'}/,@must;
		}
	}

	foreach my $attr (sort @attributes) {
		next if ($attr eq "objectClass");
		next if grep /$attr/,@{${$c->config}{'Controller::User'}{'skip_attrs'}};
		my @vals = $entry->get_value($attr);
		$attrdef = $schema->attribute($attr) or die ("getting schema failed: $!");
		my %valhash = (  
			name => $attr,
			values => \@vals,
			desc => $$attrdef{'desc'},
		);
		if (! grep /^$attr$/, @{${$c->config}{'Controller::User'}{'uneditable_attrs'}}) { 
			$valhash{'editable'} = 1;
		}
		if (! $$attrdef{'single-value'} && $valhash{'editable'}) { $valhash{'addable'} = 1; }
		if (! grep /$attr/,@must) { $valhash{'removable'} = 1; }
		push @values, \%valhash;
	}
	foreach my $oc (@ocs) {
		foreach my $attrdef ($schema->may($oc)) {
			my $attrname = $$attrdef{'name'};
			grep /$attrname/,@may or 
			grep /$attrname/,@attributes or 
			grep /$attrname/,@{${$c->config}{'Controller::User'}{'uneditable_attrs'}} or 
			grep /$attrname/,@{${$c->config}{'Controller::User'}{'skip_attrs'}} or 
			push @may, $attrname;
		}
	}
	@may = sort @may;
	$c->stash({ username => $user,
			values => \@values,
			attrdef => $attrdef,
			may => \@may,
			must => \@must,
		});
}

sub add : Local  {
	my ( $self, $c) = @_;
	my ($mesg,$entry,$user,$attr,$value);
	$attr = $c->req->param('attribute');
	$value = $c->req->param('value');
	$user = $c->user->username;
	$c->log->info("Searching for user $user");
	$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
	$entry = $mesg->entry;
	$entry->add( $attr => $value);
	$c->log->info("Adding $attr = $value to user $user");
	$entry->update;
	push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
	$c->log->info($mesg->error);
    	$c->res->redirect('/user');
}
	
sub delete : Local : Args(2) {
	my ( $self, $c, $attrname,$attrvalue) = @_;
	my ($mesg,$entry,$user);
	$user = $c->user->username;
	$c->log->info("Searching for user $user");
	$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
	$entry = $mesg->entry;
	$c->log->info("Deleting $attrname = $attrvalue from user $user");
	$entry->delete($attrname => $attrvalue);
	$entry->update;
	push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
	$c->log->info($mesg->error);
    	$c->res->redirect('/user');
}

sub password : Local {
	my ( $self, $c) = @_;
	my ($mesg,$newpass,$cipher);
	if ( not defined $c->req->param('password') or not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
	#if ( not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
		$c->detach;	
	}
	if ($c->req->param('newpassword1') eq $c->req->param('newpassword2')) {
		$newpass = $c->req->param('newpassword1');
	} else {
		push @{${$c->stash}{'errors'}},"New passwords dont match";
	}
	my $pp = Net::LDAP::Control::PasswordPolicy->new;
	$mesg = $c->model('User')->set_password( 
		oldpasswd => $c->req->param('password'),
       		newpasswd => $newpass,
		control => [ $pp ],
	);
	if ($mesg->code) {
		my $perror = $mesg->error;
		push @{${$c->stash}{'errors'}},"Password change failed: $perror";
		$c->detach;
	} else {
		# re-encrypt the new password and forward to user view
		my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
		$cipher = Crypt::CBC->new( -key    => $keyprefix . $c->sessionid,
				-cipher => 'Blowfish'
			) or die $!;
		$c->session->{enc_password} = $cipher->encrypt($newpass);
		push @{${$c->stash}{'errors'}},"Password change succeeded";
    		$c->res->redirect('/user');
	}	
		

}

sub firstlogin : Local {
	my ( $self, $c ) = @_;
	my ($mesg,$newpass,$cipher);

	if (! $c->authenticate({ 
				username => $c->req->param('username'),
				password => $c->req->param('key')}) ) {
		$c->stash(errors => ['An error occurred']);
    		$c->res->redirect('/user');
	}

	if ( not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
		$c->detach;	
	}
	if ($c->req->param('newpassword1') eq $c->req->param('newpassword2')) {
		$newpass = $c->req->param('newpassword1');
	} else {
		push @{${$c->stash}{'errors'}},"New passwords dont match";
	}
	my $pp = Net::LDAP::Control::PasswordPolicy->new;
	$mesg = $c->model('User')->set_password( 
		#oldpasswd => $c->req->param('password'),
       		newpasswd => $newpass,
		control => [ $pp ],
	);
	if ($mesg->code) {
		my $perror = $mesg->error;
		push @{${$c->stash}{'errors'}},"Password change failed: $perror";
		$c->detach;
	} else {
		# re-encrypt the new password and forward to user view
		my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
		$cipher = Crypt::CBC->new( -key    => $keyprefix . $c->sessionid,
				-cipher => 'Blowfish'
			) or die $!;
		$c->session->{enc_password} = $cipher->encrypt($newpass);
		push @{${$c->stash}{'errors'}},"Password change succeeded";
    		$c->res->redirect('/user');
	}	

}

sub login : Local {
    my ( $self, $c ) = @_;
    if ($c->authenticate({ username => $c->req->param('username'),
                           password => $c->req->param('password') || $c->req->param('key')}) ) {
    	$c->res->redirect('/user');
    } else {
    	#TODO: ppolicy ....
    	$c->stash(errors => ['Incorrect username or password']);
	$c->stash(template => 'index.tt');
	$c->forward('/index');
    }
    return $c->error;
}

sub logout : Local {
    my ( $self, $c ) = @_;
    $c->delete_session; 
    $c->res->redirect('/');
}

=head1 AUTHOR

Buchan Milne

=head1 LICENSE

This library is free software. You can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

__PACKAGE__->meta->make_immutable;

1;