linuxdv-backend/lib/LDV/LDAP.pm

package LDV::LDAP;

use strict;
use warnings;
use utf8;

use Net::LDAP;
use Net::LDAP::Util qw(ldap_error_name);
use Crypt::SaltedHash;

sub new {
  my ($class, $opts) = @_;
  my $self = {
    server      => undef,
    binddn      => undef,
    bindpass    => undef,
    userbase    => undef,
    userfilter  => "(class=InetOrgPerson)",
    %$opts,
  };

  return bless($self, $class);
}

sub _connect {
  my ($self) = @_;
  my $conn = Net::LDAP->new($self->{server}, onerror => 'die');
  $conn->bind($self->{binddn}, password => $self->{bindpass});

  return $conn;
}

sub _escape {
  my ($self, $str) = @_;
  $str =~ s|\\|\\\\|go;
  $str =~ s|\(|\\\(|go;
  $str =~ s|\)|\\\)|go;
  return $str;
}

sub _uid_to_dn {
  my ($self, $uid) = @_;
  return sprintf "uid=%s,%s", $uid, $self->{userbase};
}

sub _filter_username {
  my ($self, $uid) = @_;
  return bless({and =>
    [{equalityMatch => {attributeDesc  => 'objectClass',
                        assertionValue => 'inetOrgPerson'}},
     {equalityMatch => {attributeDesc  => 'uid',
                        assertionValue => $uid}}
   ]}, 'Net::LDAP::Filter');
};

sub auth {
  my ($self, $uid, $pass) = @_;
  return unless ($uid and $pass);

  my $dn = $self->_uid_to_dn($uid);
  my $conn = Net::LDAP->new($self->{server}, onerror => sub { return shift });
  my $result = $conn->bind($dn, password => $pass);
  $conn->unbind;
  $conn->disconnect;
  return if $result->code;
  return 1;
}

sub chpass {
  my ($self, $uid, $newpass) = @_;

  my $csh = Crypt::SaltedHash->new(algorithm => 'SHA-1');
  $csh->add($newpass);

  return $self->update($uid, {userPassword => $csh->generate()});
}

sub create {
  my ($self, $uid) = @_;
  my $conn   = $self->_connect();
  $uid = $self->_escape($uid);
  my $data = $self->get($uid);
  return "User already exists"
    if ($data);

  my $dn = $self->_uid_to_dn($uid);
  my $result = $conn->add($dn, attr => [
    objectClass  => ['inetOrgPerson'],
    uid => $uid,
    cn  => 'just',
    sn  => 'created',
  ]);
  $conn->unbind;
  $conn->disconnect;
  return $result->error if ($result->code);
  return;
}

sub delete {
  my ($self, $uid) = @_;
  my $conn   = $self->_connect();
  $uid = $self->_escape($uid);
  my $dn = $self->_uid_to_dn($uid);
  my $result = $conn->delete($dn);
  $conn->unbind;
  $conn->disconnect;
  return $result->error if ($result->code);
  return;
}

sub get {
  my ($self, $uid) = @_;
  my $conn   = $self->_connect();
  my $filter = $self->_filter_username($uid);
  my $mesg = $conn->search(base => $self->{userbase}, scope => 'one',
                           deref => 'never', filter => $filter);
  $conn->unbind;
  $conn->disconnect;
  return unless $mesg->count;
  my $entry = $mesg->pop_entry();
  my $data = {};
  foreach my $attr ($entry->attributes) {
    $data->{$attr} = $entry->get_value($attr);
    utf8::decode($data->{$attr});
  }

  delete $data->{objectClass};
  return $data;
}

sub update {
  my ($self, $uid, $attrs) = @_;
  return "Attrs isn't HASH"
    if (ref($attrs) ne 'HASH');

  my $conn   = $self->_connect();
  $uid = $self->_escape($uid);

  my $data = $self->get($uid);
  return "No such user"
    unless ($data);

  my $dn = $self->_uid_to_dn($uid);
  my %allowed = map { $_ => 1 } @{$self->{defattrs}};
  my @chg = ();
  while (my ($key, $value) =  each(%$attrs)) {
    next unless exists $allowed{$key};
    next if ($key =~ m/uid/);         # rename protection
    next if ($key =~ m/objectClass/); # class protection
    if ($value and not exists $data->{$key}) {
      push @chg, add => [$key => $value];
      next;
    }
    if ($data->{$key} and $value) {
      push @chg, replace => [$key => $value];
      next;
    }
    if ($data->{$key} and not $value) {
      push @chg, delete => [$key => $value];
      next;
    }
  }
  my $result = $conn->modify($dn, changes => \@chg);
  $conn->unbind;
  $conn->disconnect;

  return $result->error if ($result->code);
  return;
}

1;

=pod

=head1 NAME

LDV::LDAP -- ldap routines

=head1 METHODS

=head2 C<new>

  my $ldap = LDV::LDAP->new(\%opts);

* server -- server to connect to (ip-address, default: localhost)
* binddn   -- auth as this DB (like cn=admin,dc=example,dc=com, default: unset)
* bindpass -- auth with this password (string, default: unset)
* userbase -- where to search for users, (like dc=example,dc=com, default: unset)
* userfilter -- objects that pass the filter, considered as users (default : "(class=InetOrgPerson)"

=head2 C<auth>

  my $ldap = LDV::LDAP->new(\%opts);
  my $result = $ldap->auth($username, $password);

Check user/pass pair against ldap server.
Returns 1 on success or undef on auth failure/error;

=head2 C<chpass>

  my $ldap = LDV::LDAP->new(\%opts);
  my $result = $ldap->chpass($username, $password);

Changes user password.
Returns nothing on success or scalar with text on error.

=head2 C<create>

  my $ldap = LDV::LDAP->new(\%opts);
  my $err = $ldap->create($username);

Returns nothing on success or scalar with text of error.

=head2 C<delete>

  my $ldap = LDV::LDAP->new(\%opts);
  my $err = $ldap->delete($username);

Returns nothing on success or scalar with text of error.

=head2 C<get>

  my $ldap = LDV::LDAP->new(\%opts);
  my $attrs = $ldap->get($username);

Get user attributes. Returns HASH on success or undef if not found.

=head2 C<update>

  my $ldap = LDV::LDAP->new(\%opts);
  my $err = $ldap->update($user, \%attrs);

Returns nothing on success or scalar with text on error.

See list of allowed keys in config, 'ldap/defattrs' parameter.
'uid' key will be ignored, because it's structural in our schema.

=cut