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::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 ) = @_;
    if ($c->req->path eq 'user/firstlogin') {
	return 1;
    }
    my $cipher;
    my $password;
    my $mesg;
    my $dn;
    my @errors;
    my $keyprefix = $self->get_keyprefix($c);
    if (! defined $c->user or not $c->req->cookie('key')) {
	if (not $c->req->param('password')) {
	    push @errors,$c->loc('Your session has expired');
	    $c->stash(template => 'index.tt',errors => \@errors);
	    $c->detach;
	}

        $c->log->debug("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->debug('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->debug("Re-authenticating user " . $c->user->username);
        $c->authenticate({username => $c->user->username,password => $password});
	$c->res->cookies->{'key'} = {value => $key, expires => '+10m'};

        $c->stash(pages => roles2pages($c->user->roles));
        $c->log->info($@) if $@;
        return 1;
    }

}

sub get_keyprefix : Private {
    my ( $self, $c ) = @_;
    my $keyprefix;
    if ($c->req->address =~ m/:/) {
        my $address = $c->req->address;
        $address =~ s/\[\]://;

        # if we shift right 104 bits from 128 we have 24 bits left or 3 bytes.
        $keyprefix = sprintf( "%06x", $address >> 104 );
    }
    else {
        $keyprefix = sprintf( "%02x%02x%02x", split /\./, $c->req->address );
    }
    return $keyprefix;
}

=head2 index

=cut

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

    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;
    $userfilter = $c->user->store->user_filter;
    $userfilter =~ s/\%s/$user/g,
    $c->log->debug("Searching for user $user with filter $userfilter");
    $mesg = $c->model('User')->search($userfilter);
    $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($userfilter);
    $c->log->debug($mesg->error) if $mesg->code;
    $entry = $mesg->entry;
    $c->log->debug($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 $attr = $c->req->param('attribute');
    my $value = $c->req->param('value');
    my $user = $c->user->username;
    my $userfilter = sprintf($c->user->store->user_filter ,$c->user->username);
    $c->log->debug("Searching for user $user with $userfilter");
    my $mesg = $c->model('User')->search($userfilter);
    my $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,$userfilter);
    $user = $c->user->username;
    $userfilter = $c->user->store->user_filter;
    $userfilter =~ s/%s/$c->user->username/g;
    $c->log->debug("Searching for user $user");
    $mesg = $c->model('User')->search($userfilter);
    $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;
    }
    # Re-authenticate to check the user has the right password
    if (not $c->authenticate({
		    'username' => $c->user->username,
		    'password' => $c->req->param('password'),
	    })
	) {
	$c->stash(errors => [ $c->loc('Password incorrect') ]);
	$c->detach;
    }
    if ($c->req->param('newpassword1') eq $c->req->param('newpassword2')) {
        $newpass = $c->req->param('newpassword1');
    } else {
        push @{${$c->stash}{'errors'}},$c->loc('New passwords dont match');
	$c->detach;
    }
    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 = $self->get_keyprefix($c);
        my $key = $c->req->cookie('key')->value;
        $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
            -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);

    # we want to do our own authentication and caching here, as we
    # dont want what auto does, and auto returns early for this path

    if ( not defined $c->req->param('newpassword1') or not defined $c->req->param('newpassword2')) {
        if (! $c->authenticate({
                username => $c->req->param('username'),
                password => $c->req->param('key')}) ) {
            $c->stash(errors => ['An error occurred']);
	    $c->log->info("Failed to authenticate user in first login: " . $c->req->param('key'));
            $c->res->redirect('/user');
	}
	# cache password for next request with form data
        my $keyprefix = $self->get_keyprefix($c);
	my $key = Data::UUID->new->create_str();
        $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
                -cipher => 'Blowfish'
              ) or die $!;
        $c->session->{enc_password} = $cipher->encrypt($c->req->param('key'));
	$c->response->cookies->{'key'} = { value => $key, expires => '+10m' };
        $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";
    }

    #Re-authenticate user
    my $keyprefix = $self->get_keyprefix($c);
    my $key = $c->req->cookie('key')->value;
    $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
        -cipher => 'Blowfish'
      ) or die $!;
    my $password = $cipher->decrypt($c->session->{enc_password});
    $c->authenticate({username => $c->req->param('username'),password => $password})
	or $c->log->info("Authenticating user for first password change failed");

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

    # re-encrypt the new password and redirect to user view
    $cipher = Crypt::CBC->new( -key    => $keyprefix . $key,
            -cipher => 'Blowfish'
          ) or die $!;
    $c->session->{enc_password} = $cipher->encrypt($newpass);
    $c->authenticate({username => $c->req->param('username'),password => $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;