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

package CatDap::Controller::admin;
use Moose;
use namespace::autoclean;
use Data::UUID;
use Data::Dumper;

BEGIN { extends 'Catalyst::Controller'; }

=head1 NAME

CatDap::Controller::admin - 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->detach('/user/login')
          if ( not $c->req->param('username')
            or not $c->req->param('password') );
        $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->log->info("Logging user in failed, forwarding to login page");
            $c->visit('/user/login');
            $c->detach;
            return 1;
        }
        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->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 } )
          or $c->view('/user/login');
	$c->res->cookies->{'key'} = {value => $key, expires => '+10m'};
        $c->stash( pages => roles2pages( $c->user->roles ) );
        $c->log->info($@) if $@;
        return 1;
    }
}

sub account : Local {
    my ( $self, $c ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my @errors;
    return
      if not defined $c->req->param('attribute')
          and not defined $c->req->param('value');

    #my $attribute =~ m/^([\w\d]*)/,$c->req->param('attribute');
    my $attribute = $c->req->param('attribute');
    $c->log->info("Searching for account using attribute $attribute");

    #my $value =~ /^[\w\d]*/,$c->req->param('attribute');
    my $value = $c->req->param('value');
    my $mesg =
      $c->model('user')
      ->search("(&(objectClass=inetOrgPerson)($attribute=$value))");
    my @entries = $mesg->entries;
    push @errors, $mesg->error if $mesg->code;
    $c->stash( entries => \@entries );
    $c->stash( errors  => \@errors );
}

sub account_promote : Local {
    my ( $self, $c ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my @errors;
    if ( defined $c->req->param('gid') and defined $c->req->param('username') )
    {
        my $gid = $c->req->param('gid');
        foreach my $uid ( $c->req->param('username') ) {
            $c->log->info("Promoting user $uid with gid $gid");
            my $mesg =
              $c->model('user')
              ->search(
"(&(uid=$uid)(objectclass=inetOrgPerson)(!(objectClass=posixAccount)))"
              );
            if ( $mesg->entries gt 1 ) {
                push @errors, "More than one account matched user $uid";

                #TODO forward to error page
            }
            my $entry = $mesg->entry;
            $mesg = $c->model('user')->search("(objectclass=sambaUnixIdPool)");
            if ( $mesg->entries gt 1 ) {
                push @errors, "More than one ID Pool";

                #TODO forward to error page
            }
            my $idpool = $mesg->entry;
	    my $uidnum = $idpool->uidNumber;
	    my $newuidnum = $uidnum++;
            $entry->add(
                objectclass   => [ 'posixAccount', 'ldapPublicKey' ],
                loginShell    => '/bin/bash',
                gidNumber     => $c->req->param('gid'),
                uidNumber     => $uidnum,
                homeDirectory => "/home/$uid",
            );
            $idpool->replace( uidNumber => $newuidnum );

            $idpool->update;
            $mesg = $entry->update or $c->log->info("LDAP update failed: $!");
            if ($mesg->code) {
		push @errors, $mesg->error;
		#reverse idpool update
		$idpool->replace( uidNumber => $uidnum );
		$mesg = $idpool->update;
		$c->log->info("ERROR IdPool could not be reset to $uidnum");
	    }
        }
    }
    my $mesg =
      $c->model('user')
      ->search("(&(objectClass=inetOrgPerson)(!(objectClass=posixAccount)))");
    my @entries = $mesg->entries;
    $c->stash( entries => \@entries );
    push @errors, $mesg->error if $mesg->code;
    $mesg = $c->model('user')->search("(objectClass=posixGroup)");
    my @groups = $mesg->entries;
    $c->stash( groups => \@groups );
    $c->stash( errors => \@errors );
}

sub account_modify : Local {
    my ( $self, $c, $user ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->stash( subpages => gensubpages('account') );
    $c->assert_user_roles('Account Admins');
    my @errors;
    my $mesg;
    if ( $user eq '' ) {
        $c->forward( $c->uri_for('/account') );
        $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 $entry;
    $c->log->info("Searching for user $user");
    $mesg =
      $c->model('User')->search("(&(objectclass=inetOrgPerson)(uid=$user))");
    $entry = $mesg->entry;

    # Handle adding attributes immediately here, forwarding back to ourselves
    if ( $c->req->param('operation') eq 'add' ) {
        $entry->add( $c->req->param('attribute') => $c->req->param('value') );
        $mesg = $entry->update;
        push @errors, $mesg->error if $mesg->code;
        $c->res->redirect( $c->uri_for( $c->req->uri ) . "/$user" );
    }

    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;
    my @available_ocs = $schema->all_objectclasses;
    my @offer_ocs;
    foreach my $oc (@available_ocs) {
        my $ocname = $$oc{name};
        next if grep /$ocname/, @ocs;
        next if not $$oc{auxiliary};
        push @offer_ocs, $ocname;
    }
    @offer_ocs = sort @offer_ocs;
    my @groups;
    if ( grep /posixAccount/, @offer_ocs ) {
        my $mesg = $c->model('user')->search('objectclass=posixGroup');
        foreach my $group ( $mesg->entries ) {
            push @groups,
              {
                name      => $group->cn,
                gidNumber => $group->gidNumber,
              };
        }
    }

    $c->stash(
        {
            username  => $user,
            values    => \@values,
            attrdef   => $attrdef,
            may       => \@may,
            must      => \@must,
            offer_ocs => \@offer_ocs,
            dn        => $entry->dn,
            uid       => $entry->uid,
        }
    );
    $c->stash( 'groups' => \@groups ) if (@groups);
}

sub account_modifydel : Local {
    my ( $self, $c, $uid, $attr, $value ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my @errors;
    my $mesg;
    $mesg =
      $c->model('user')->search("(&(objectClass=inetOrgPerson)(uid=$uid))");
    push @errors, $mesg->error if $mesg->code;
    $mesg = $mesg->entry->delete( $attr => $value )->update;
    push @errors, $mesg->error if $mesg->code;
    $c->res->redirect( $c->uri_for('/admin/account_modify') . "/$uid" );
}

sub account_group : Local {
    my ( $self, $c, $uid ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    $c->res-redirect($c->uri_for('/admin/account')) if $uid eq '';
    my (@errors,@newgroups,@groups);
    my ($mesg,$entry,$dn);

    $mesg = $c->model('user')->search("(&(objectclass=inetOrgperson)(uid=$uid))");
    $entry = $mesg->entry;
    $dn = $entry->dn;
    if (defined $c->req->param('op')) {
	my $group = $c->req->param('group');
	$mesg = $c->model('user')->search("(&(objectclass=groupOfNames)(cn=$group))");
	$entry = $mesg->entry;
	$entry->delete(member => $dn) if ($c->req->param('op') eq 'delete');
	$entry->add(member => $dn) if ($c->req->param('op') eq 'add');
	$mesg = $entry->update if ($entry->changes);
	push @errors,$mesg->error if $mesg->code;
    }


    $mesg = $c->model('user')->search("(&(objectclass=groupOfNames)(member=$dn))");
    @groups = $mesg->entries;
    $mesg = $c->model('user')->search("(&(objectclass=groupOfNames)(!(member=$dn)))");
    @newgroups = $mesg->entries;
    $c->stash(
	    uid => $uid,
	    groups => \@groups,
	    newgroups => \@newgroups,    
    );
}

sub account_addoc : Local {
    my ( $self, $c ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my $objectclass = $c->req->param('objectclass')
      or $c->detach('/admin/group');
    my $dn  = $c->req->param('dn');
    my $uid = $c->req->param('uid');
    my ( @errors, @must, @may );
    my $mesg;
    my $schemaldap = Net::LDAP->new( ${ $c->config }{'Model::Proxy'}{'host'} )
      or warn "LDAP bind failed: $!";
    $mesg = $schemaldap->start_tls
      if ${ $c->config }{'Model::Proxy'}{'start_tls'};
    push @errors, $mesg->error if $mesg->code;
    $schemaldap->bind;
    push @errors, $mesg->error if $mesg->code;
    my $schema = $schemaldap->schema or die("Searching schema failed: $!");
    $mesg =
      $c->model('user')->search("(&(objectclass=inetOrgPerson)(uid=$uid))");
    $c->log->info( $mesg->error ) if $mesg->code;
    my $entry = $mesg->entry;
    $c->log->info( $mesg->error ) if $mesg->code;

    foreach my $attr ( $schema->must($objectclass) ) {
        push @must, $$attr{name} if not $entry->get_value( $$attr{name} );
    }
    foreach my $attr ( $schema->may($objectclass) ) {
        push @may, $$attr{name} if not $entry->get_value( $$attr{name} );
    }

    # if we have all the musts as params
    my $haveall = 1;
    foreach my $addattr (@must) {
        if ( defined $c->req->param($addattr) ) {
            $entry->add( $addattr => $c->req->param($addattr) );
        }
        else {
            $c->log->info("Missing attribute $addattr");
            $haveall = 0;
        }
    }
    if ($haveall) {
        $entry->add( objectClass => [$objectclass] );
        $c->log->info("About to push updates to $dn");
        $c->log->info( Dumper( \$entry->changes ) );
        $mesg = $entry->update;
        push @errors, $mesg->error if $mesg->code;
        $c->stash( template => 'admin/account.tt', errors => @errors );

        #$c->detach('account_modify');
        $c->res->redirect( $c->uri_for('/admin/account_modify') . "/" . $uid );
        $c->detach;
    }
    $c->stash(
        may  => \@may,
        must => \@must,
        oc   => $objectclass,
        dn   => $dn,
        uid  => $uid,
    );
}

sub group : Local {
    my ( $self, $c ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my @errors;
    return if not $c->req->param('attribute') and not $c->req->param('value');
    my $attribute = $c->req->param('attribute');
    $attribute =~ s/[^\w\d]//g;
    my $value = $c->req->param('value');
    $value =~ s/[^\w\d\*]//g;
    my $mesg =
      $c->model('user')
      ->search("(&(objectclass=posixGroup)($attribute=$value))");
    push @errors, $mesg->error if $mesg->code;
    my @entries = $mesg->entries;
    push @errors, $mesg->error if $mesg->code;
    $c->stash(
        entries => \@entries,
        errors  => \@errors,
    );
}

sub group_modify : Local {
    my ( $self, $c, $group ) = @_;
    $c->detach('/user/login') if not $c->user;
    $c->assert_user_roles('Account Admins');
    $c->stash( subpages => gensubpages('account') );
    my @errors;
    $c->detach('/admin/group') if $group eq '';
    if ( $group !~ /^[\w\d]*$/ ) {
        push @errors, "Group contains illegal characters";
        $c->detach('admin/group');
    }
    my $mesg =
      $c->model('user')->search("(&(objectClass=posixGroup)(cn=$group))");
    if ( $mesg->entries gt 1 ) {
        push @errors, 'More than one entry matched';
        $c->detach('/admin/group');
    }
    $c->stash( group => $mesg->entry );
}

=head2 index

=cut

sub index : Path : Args(0) {
    my ( $self, $c ) = @_;
    $c->stash( pages => roles2pages( $c->user->roles ) );

#$c->response->body("Matched CatDap::Controller::admin in admin, roles $rolelist");
}

sub roles2pages : Private {
    my @roles = @_;
    my @pages;
    foreach my $role ( sort @roles ) {
        if ( $role =~ /^(\w+) ?(\w*) (Admin|User)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;
    if ( $type eq 'account' ) {
        @subpagenames = (
            { page => 'account',         title => "Users" },
	    { page => 'account_promote', title => "Promote" },
	    #{ page => 'account_unlock',  title => "Unlock" },
            { page => 'group',           title => "Groups" },
        );
    }
    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;