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::UUID;
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 a UUID string (stored in
a cookie) as the key. To access the password, an attacker would need:
- the first 3 octets of IPv4 request (not stored anywhere, but accessible
  in server logs)
- the encrpyted password (only available server-side in the session variable)
- the UUID key portion (only available on the browser-side in a cookie)

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('/user/login');
        } else {

            #if (defined $c->user->pwdReset) {
            #   $c->res->redirect('/user');
            #}
            #$c->persist_user;
            $c->log->info('Logging user in to LDAP');

            my $ug =  Data::UUID->new;
            my $key = $ug->create_str();
            $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
                -cipher => 'Blowfish'
              ) or die $!;
            $c->session->{enc_password} = $cipher->encrypt($c->req->param('password') || $c->req->param('key'));
            $c->response->cookies->{'key'} = { value => $key, expires => '+10m' };
            $c->stash(pages => roles2pages($c->user->roles));
            $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 {
        my $key = $c->req->cookie('key')->value;
        $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
            -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->stash(pages => roles2pages($c->user->roles));
        $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,
        });
    $c->stash(subpages => gensubpages());
}

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);
    $c->stash(subpages => gensubpages());
    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('/');
}

sub roles2pages : Private {
    my @roles = @_;
    my @pages;
    foreach my $role (sort @roles) {
        if ($role =~ /^(\w+) ?(\w*) (Admin)s$/) {
            my $page = lc("/$3/$1$2");
            push @pages,{ page => lc("/$3/$1$2"), title => "$1 $2 $3"};
        }
    }
    return \@pages;
}

sub gensubpages : Private {
    my ($type) = @_;
    my @subpagenames;
    @subpagenames = (
        { page => './', title => "Edit"},
        { page => 'password', title => "Change password"},
      );
    return \@subpagenames;
}

=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;
1	buchan	4	package CatDap::Controller::user;
2			use Moose;
3			use namespace::autoclean;
4	buchan	5	use Net::LDAP;
5			use Net::LDAP::Schema;
6			use Net::LDAP::Extension::SetPassword;
7			use Net::LDAP::Control::PasswordPolicy 0.02;
8			use Crypt::CBC;
9	buchan	43	use Data::UUID;
10	buchan	5	use Data::Dumper;
11	buchan	4
12			BEGIN {extends 'Catalyst::Controller'; }
13
14			=head1 NAME
15
16			CatDap::Controller::user - Catalyst Controller
17
18			=head1 DESCRIPTION
19
20			Catalyst Controller.
21
22			=head1 METHODS
23
24			=cut
25
26	buchan	5	=head2 auto
27	buchan	4
28	buchan	5	Ensure the user is logged in. In order to bind as the user, we use
29			CatDap::Model::User, which uses Catalyst::Model::LDAP::FromAuthentication,
30			which effectively requires calling $c->authenticate on every request.
31
32			To do this, we keep the password, encrypted with blowfish, using the
33	buchan	43	(for now), first 3 octets of IPv4 request address and a UUID string (stored in
34			a cookie) as the key. To access the password, an attacker would need:
35			- the first 3 octets of IPv4 request (not stored anywhere, but accessible
36			in server logs)
37			- the encrpyted password (only available server-side in the session variable)
38			- the UUID key portion (only available on the browser-side in a cookie)
39	buchan	5
40			So, if the user does "not exist", we authenticate them, if it succeeds we encrypt
41			the password and store it in the session.
42
43			If the user is logged in, we get the encrypted password from the session, decrypt
44			it (we need to handle failure to decrypt it better)
45
46			=cut
47
48			sub auto : Private {
49			my ( $self, $c ) = @_;
50	buchan	42	my $cipher;
51			my $password;
52			my $mesg;
53			my $dn;
54			my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
55			if (! defined $c->user) {
56			$c->log->info("No session, logging user in");
57			if (! $c->authenticate({ username => $c->req->param('username'),
58			password => $c->req->param('password') \|\| $c->req->param('key')}) ) {
59	buchan	5
60	buchan	42	#TODO: ppolicy ....
61			$c->stash(errors => ['Incorrect username or password']);
62			$c->stash(template => 'index.tt');
63	buchan	38
64	buchan	42	#$c->forward('/index');
65			$c->detach('/user/login');
66			} else {
67	buchan	5
68	buchan	42	#if (defined $c->user->pwdReset) {
69			# $c->res->redirect('/user');
70			#}
71			#$c->persist_user;
72			$c->log->info('Logging user in to LDAP');
73	buchan	43
74			my $ug = Data::UUID->new;
75			my $key = $ug->create_str();
76			$cipher = Crypt::CBC->new( -key => $keyprefix . $key,
77	buchan	42	-cipher => 'Blowfish'
78			) or die $!;
79			$c->session->{enc_password} = $cipher->encrypt($c->req->param('password') \|\| $c->req->param('key'));
80	buchan	43	$c->response->cookies->{'key'} = { value => $key, expires => '+10m' };
81	buchan	42	$c->stash(pages => roles2pages($c->user->roles));
82			$c->session->{dn} = $c->user->ldap_entry->dn;
83			$c->session->{user} = $c->req->param('username');
84			$password = $c->req->param('password') \|\| $c->req->param('key');
85			return 1;
86			}
87
88			} else {
89	buchan	43	my $key = $c->req->cookie('key')->value;
90			$cipher = Crypt::CBC->new( -key => $keyprefix . $key,
91	buchan	42	-cipher => 'Blowfish'
92			) or die $!;
93			$password = $cipher->decrypt($c->session->{enc_password});
94			$c->log->info("Re-authenticating user " . $c->session->{user});
95			$c->authenticate({username => $c->session->{user},password => $password});
96
97			$c->stash(pages => roles2pages($c->user->roles));
98			$c->log->info($@) if $@;
99			return 1;
100			}
101
102	buchan	5	}
103
104	buchan	4	=head2 index
105
106			=cut
107
108			sub index :Path :Args(0) {
109	buchan	42	my ( $self, $c ) = @_;
110			my $cipher;
111			my $password;
112			my $mesg;
113			my $dn;
114	buchan	4
115	buchan	42	if (not defined $c->user ) {
116			$c->stash(template => 'index.tt');
117			$c->forward('/index');
118			$c->detach;
119			}
120			my $schemaldap = Net::LDAP->new(${$c->config}{'Model::Proxy'}{'host'}) or warn "LDAP bind failed: $!";
121			$schemaldap->start_tls if ${$c->config}{'Model::Proxy'}{'start_tls'};
122			$schemaldap->bind;
123			my $schema = $schemaldap->schema or die ("Searching schema failed: $!");
124			my $attrdef;
125	buchan	5
126	buchan	42	my $user = $c->user->username;
127			my $entry;
128			$c->log->info("Searching for user $user");
129			$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
130			$entry = $mesg->entry;
131			my %mods;
132			my %params = %{$c->req->parameters};
133			my $update = 0;
134			foreach my $req (keys %params) {
135			next if $req !~ /(.+)_new/;
136			my $attrname = $1;
137			next if $params{$attrname . '_new'} eq $params{$attrname . '_old'};
138			$c->log->info("Received update request for attribute $attrname");
139			$update = 1;
140			$attrdef = $schema->attribute($attrname) or die ("getting schema failed: $!");
141			if ($$attrdef{'single-value'}) {
142			$entry->replace($attrname => $params{$attrname . '_new' }) or $c->log->info($!);
143			} else {
144			$entry->delete($attrname => $params{$attrname . '_old'});
145			$entry->add($attrname => $params{$attrname . '_new'});
146			}
147			if ($update) {
148			$mesg = $entry->update;
149			push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
150			}
151			}
152	buchan	5
153	buchan	42	$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
154			$c->log->info($mesg->error) if $mesg->code;
155			$entry = $mesg->entry;
156			$c->log->info($mesg->error) if $mesg->code;
157	buchan	5
158	buchan	42	my @values;
159			my @attributes = $entry->attributes;
160			my @may;
161			my @addable_attrs = @attributes;
162			my @ocs;
163			my @must;
164			@ocs = $entry->get_value("objectClass");
165			foreach my $oc (@ocs) {
166			foreach my $attr ($schema->must($oc)) {
167			push @must,$$attr{'name'} if not grep /$$attr{'name'}/,@must;
168			}
169			}
170	buchan	5
171	buchan	42	foreach my $attr (sort @attributes) {
172			next if ($attr eq "objectClass");
173			next if grep /$attr/,@{${$c->config}{'Controller::User'}{'skip_attrs'}};
174			my @vals = $entry->get_value($attr);
175			$attrdef = $schema->attribute($attr) or die ("getting schema failed: $!");
176			my %valhash = (
177			name => $attr,
178			values => \@vals,
179			desc => $$attrdef{'desc'},
180			);
181			if (! grep /^$attr$/, @{${$c->config}{'Controller::User'}{'uneditable_attrs'}}) {
182			$valhash{'editable'} = 1;
183			}
184			if (! $$attrdef{'single-value'} && $valhash{'editable'}) { $valhash{'addable'} = 1; }
185			if (! grep /$attr/,@must) { $valhash{'removable'} = 1; }
186			push @values, \%valhash;
187			}
188			foreach my $oc (@ocs) {
189			foreach my $attrdef ($schema->may($oc)) {
190			my $attrname = $$attrdef{'name'};
191			grep /$attrname/,@may or
192			grep /$attrname/,@attributes or
193			grep /$attrname/,@{${$c->config}{'Controller::User'}{'uneditable_attrs'}} or
194			grep /$attrname/,@{${$c->config}{'Controller::User'}{'skip_attrs'}} or
195			push @may, $attrname;
196			}
197			}
198			@may = sort @may;
199			$c->stash({ username => $user,
200			values => \@values,
201			attrdef => $attrdef,
202			may => \@may,
203			must => \@must,
204			});
205			$c->stash(subpages => gensubpages());
206	buchan	4	}
207
208	buchan	5	sub add : Local {
209	buchan	42	my ( $self, $c) = @_;
210			my ($mesg,$entry,$user,$attr,$value);
211			$attr = $c->req->param('attribute');
212			$value = $c->req->param('value');
213			$user = $c->user->username;
214			$c->log->info("Searching for user $user");
215			$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
216			$entry = $mesg->entry;
217			$entry->add( $attr => $value);
218			$c->log->info("Adding $attr = $value to user $user");
219			$entry->update;
220			push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
221			$c->log->info($mesg->error);
222			$c->res->redirect('/user');
223	buchan	5	}
224	buchan	42
225	buchan	5	sub delete : Local : Args(2) {
226	buchan	42	my ( $self, $c, $attrname,$attrvalue) = @_;
227			my ($mesg,$entry,$user);
228			$user = $c->user->username;
229			$c->log->info("Searching for user $user");
230			$mesg = $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
231			$entry = $mesg->entry;
232			$c->log->info("Deleting $attrname = $attrvalue from user $user");
233			$entry->delete($attrname => $attrvalue);
234			$entry->update;
235			push @{${$c->stash}{'errors'}},$mesg->error if $mesg->code;
236			$c->log->info($mesg->error);
237			$c->res->redirect('/user');
238	buchan	5	}
239
240			sub password : Local {
241	buchan	42	my ( $self, $c) = @_;
242			my ($mesg,$newpass,$cipher);
243			$c->stash(subpages => gensubpages());
244			if ( not defined $c->req->param('password') or not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
245	buchan	38
246	buchan	42	#if ( not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
247	buchan	5
248	buchan	42	$c->detach;
249			}
250			if ($c->req->param('newpassword1') eq $c->req->param('newpassword2')) {
251			$newpass = $c->req->param('newpassword1');
252			} else {
253			push @{${$c->stash}{'errors'}},"New passwords dont match";
254			}
255			my $pp = Net::LDAP::Control::PasswordPolicy->new;
256			$mesg = $c->model('User')->set_password(
257			oldpasswd => $c->req->param('password'),
258			newpasswd => $newpass,
259			control => [ $pp ],
260			);
261			if ($mesg->code) {
262			my $perror = $mesg->error;
263			push @{${$c->stash}{'errors'}},"Password change failed: $perror";
264			$c->detach;
265			} else {
266
267			# re-encrypt the new password and forward to user view
268			my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
269			$cipher = Crypt::CBC->new( -key => $keyprefix . $c->sessionid,
270			-cipher => 'Blowfish'
271			) or die $!;
272			$c->session->{enc_password} = $cipher->encrypt($newpass);
273			push @{${$c->stash}{'errors'}},"Password change succeeded";
274			$c->res->redirect('/user');
275			}
276
277	buchan	5	}
278
279			sub firstlogin : Local {
280	buchan	42	my ( $self, $c ) = @_;
281			my ($mesg,$newpass,$cipher);
282	buchan	5
283	buchan	42	if (! $c->authenticate({
284			username => $c->req->param('username'),
285			password => $c->req->param('key')}) ) {
286			$c->stash(errors => ['An error occurred']);
287			$c->res->redirect('/user');
288			}
289	buchan	5
290	buchan	42	if ( not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
291			$c->detach;
292			}
293			if ($c->req->param('newpassword1') eq $c->req->param('newpassword2')) {
294			$newpass = $c->req->param('newpassword1');
295			} else {
296			push @{${$c->stash}{'errors'}},"New passwords dont match";
297			}
298			my $pp = Net::LDAP::Control::PasswordPolicy->new;
299			$mesg = $c->model('User')->set_password(
300	buchan	5
301	buchan	42	#oldpasswd => $c->req->param('password'),
302			newpasswd => $newpass,
303			control => [ $pp ],
304			);
305			if ($mesg->code) {
306			my $perror = $mesg->error;
307			push @{${$c->stash}{'errors'}},"Password change failed: $perror";
308			$c->detach;
309			} else {
310
311			# re-encrypt the new password and forward to user view
312			my $keyprefix = sprintf("%02x%02x%02x",split /\./,$c->req->address);
313			$cipher = Crypt::CBC->new( -key => $keyprefix . $c->sessionid,
314			-cipher => 'Blowfish'
315			) or die $!;
316			$c->session->{enc_password} = $cipher->encrypt($newpass);
317			push @{${$c->stash}{'errors'}},"Password change succeeded";
318			$c->res->redirect('/user');
319			}
320
321	buchan	5	}
322
323	buchan	4	sub login : Local {
324			my ( $self, $c ) = @_;
325			if ($c->authenticate({ username => $c->req->param('username'),
326	buchan	42	password => $c->req->param('password') \|\| $c->req->param('key')}) ) {
327			$c->res->redirect('/user');
328	buchan	4	} else {
329	buchan	42
330			#TODO: ppolicy ....
331			$c->stash(errors => ['Incorrect username or password']);
332			$c->stash(template => 'index.tt');
333			$c->forward('/index');
334	buchan	4	}
335	buchan	5	return $c->error;
336	buchan	4	}
337
338	buchan	5	sub logout : Local {
339			my ( $self, $c ) = @_;
340	buchan	42	$c->delete_session;
341	buchan	5	$c->res->redirect('/');
342			}
343	buchan	4
344	buchan	38	sub roles2pages : Private {
345			my @roles = @_;
346			my @pages;
347			foreach my $role (sort @roles) {
348			if ($role =~ /^(\w+) ?(\w*) (Admin)s$/) {
349	buchan	42	my $page = lc("/$3/$1$2");
350			push @pages,{ page => lc("/$3/$1$2"), title => "$1 $2 $3"};
351	buchan	38	}
352			}
353			return \@pages;
354			}
355
356			sub gensubpages : Private {
357			my ($type) = @_;
358			my @subpagenames;
359			@subpagenames = (
360	buchan	42	{ page => './', title => "Edit"},
361			{ page => 'password', title => "Change password"},
362			);
363	buchan	38	return \@subpagenames;
364			}
365
366	buchan	4	=head1 AUTHOR
367
368			Buchan Milne
369
370			=head1 LICENSE
371
372			This library is free software. You can redistribute it and/or modify
373			it under the same terms as Perl itself.
374
375			=cut
376
377			__PACKAGE__->meta->make_immutable;
378
379			1;