preliminary ldap export

4 files changed, 277 insertions, 0 deletions

diff --git a/FS/FS/part_export.pm b/FS/FS/part_export.pm
index 5d725ab22..79fe91396 100644
--- a/FS/FS/part_export.pm
+++ b/FS/FS/part_export.pm
@@ -724,6 +724,32 @@ tie my %sqlmail_options, 'Tie::IxHash',
   'password' => { label=>'Database password' },
 ;
 
+tie my %ldap_options, 'Tie::IxHash',
+  'dn'         => { label=>'DN' },
+  'password'   => { label=>'Optional DN password' },
+  'attributes' => { label=>'Attributes',
+                    type=>'textarea',
+                    default=>join("\n",
+                      'uid $username',
+                      'mail $username\@$domain',
+                      'uidno $uid',
+                      'gidno $gid',
+                      'cn $first',
+                      'sn $last',
+                      'mailquota $quota',
+                      'vmail',
+                      'location',
+                      'mailtag',
+                      'mailhost',
+                      'mailmessagestore $dir',
+                      'userpassword $crypt_password',
+                      'hint',
+                      'answer $sec_phrase',
+                    ),
+                  },
+  'radius'     => { label=>'Export RADIUS attributes', type=>'checkbox', },
+;
+
 
 #export names cannot have dashes...
 %exports = (
@@ -766,6 +792,12 @@ tie my %sqlmail_options, 'Tie::IxHash',
       'notes' => 'Run remote commands via SSH.  username@domain (rather than just usernames) are considered unique (also see shellcommands).  You probably want this if the commands you are running will accept a domain as a parameter, and will allow the same username with different domains.  You will need to <a href="../docs/ssh.html">setup SSH for unattended operation</a>.',
     },
 
+    'ldap' => {
+      'desc' => 'Real-time export to LDAP',
+      'options' => \%ldap_options,
+      'notes' => 'Real-time export to arbitrary LDAP attributes.  Requires installation of <a href="http://search.cpan.org/search?dist=Net-LDAP">Net::LDAP</a> from CPAN.',
+    },
+
     'sqlradius' => {
       'desc' => 'Real-time export to SQL-backed RADIUS (ICRADIUS, FreeRADIUS)',
       'options' => \%sqlradius_options,
diff --git a/FS/FS/part_export/ldap.pm b/FS/FS/part_export/ldap.pm
new file mode 100644
index 000000000..40f27d695
--- /dev/null
+++ b/FS/FS/part_export/ldap.pm
@@ -0,0 +1,238 @@
+package FS::part_export::ldap;
+
+use vars qw(@ISA);
+use FS::Record qw( dbh );
+use FS::part_export;
+
+@ISA = qw(FS::part_export);
+
+sub rebless { shift; }
+
+sub _export_insert {
+  my($self, $svc_acct) = (shift, shift);
+
+  #false laziness w/shellcommands.pm
+  {
+    no strict 'refs';
+    ${$_} = $svc_acct->getfield($_) foreach $svc_acct->fields;
+    ${$_} = $svc_acct->$_() foreach qw( domain );
+    my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
+    if ( $cust_pkg ) {
+      my $cust_main = $cust_pkg->cust_main;
+      ${$_} = $cust_main->getfield($_) foreach qw(first last);
+    }
+  }
+  $crypt_password = ''; #surpress "used only once" warnings
+  $crypt_password = crypt( $svc_acct->_password,
+                             $saltset[int(rand(64))].$saltset[int(rand(64))] );
+
+
+  my %attrib = map    { /^\s*(\w+)\s+(.*\S)\s*$/; ( $1 => eval(qq("$2")) ); }
+                 grep { /^\s*(\w+)\s+(.*\S)\s*$/ }
+                   split("\n", $self->option('attributes'));
+
+  if ( $self->option('radius') {
+    foreach my $table (qw(reply check)) {
+      my $method = "radius_$table";
+      my %radius = $svc_acct->$method();
+      foreach my $radius ( keys %radius ) {
+        ( my $ldap = $radius ) =~ s/\-//g;
+        $attrib{$ldap} = $radius{$radius};
+      }
+    }
+  }
+
+  my $err_or_queue = $self->ldap_queue( $svc_acct->svcnum, 'insert',
+    #$svc_acct->username,
+    %attrib );
+  return $err_or_queue unless ref($err_or_queue);
+
+  #groups with LDAP?
+  #my @groups = $svc_acct->radius_groups;
+  #if ( @groups ) {
+  #  my $err_or_queue = $self->ldap_queue(
+  #    $svc_acct->svcnum, 'usergroup_insert',
+  #    $svc_acct->username, @groups );
+  #  return $err_or_queue unless ref($err_or_queue);
+  #}
+
+  '';
+}
+
+sub _export_replace {
+  my( $self, $new, $old ) = (shift, shift, shift);
+
+  local $SIG{HUP} = 'IGNORE';
+  local $SIG{INT} = 'IGNORE';
+  local $SIG{QUIT} = 'IGNORE';
+  local $SIG{TERM} = 'IGNORE';
+  local $SIG{TSTP} = 'IGNORE';
+  local $SIG{PIPE} = 'IGNORE';
+
+  return "can't (yet?) change username with ldap"
+    if $old->username ne $new->username;
+
+  return "ldap replace unimplemented";
+
+  my $oldAutoCommit = $FS::UID::AutoCommit;
+  local $FS::UID::AutoCommit = 0;
+  my $dbh = dbh;
+
+  my $jobnum = '';
+  #if ( $old->username ne $new->username ) {
+  #  my $err_or_queue = $self->ldap_queue( $new->svcnum, 'rename',
+  #    $new->username, $old->username );
+  #  unless ( ref($err_or_queue) ) {
+  #    $dbh->rollback if $oldAutoCommit;
+  #    return $err_or_queue;
+  #  }
+  #  $jobnum = $err_or_queue->jobnum;
+  #}
+
+  foreach my $table (qw(reply check)) {
+    my $method = "radius_$table";
+    my %new = $new->$method();
+    my %old = $old->$method();
+    if ( grep { !exists $old{$_} #new attributes
+                || $new{$_} ne $old{$_} #changed
+              } keys %new
+    ) {
+      my $err_or_queue = $self->ldap_queue( $new->svcnum, 'insert',
+        $table, $new->username, %new );
+      unless ( ref($err_or_queue) ) {
+        $dbh->rollback if $oldAutoCommit;
+        return $err_or_queue;
+      }
+      if ( $jobnum ) {
+        my $error = $err_or_queue->depend_insert( $jobnum );
+        if ( $error ) {
+          $dbh->rollback if $oldAutoCommit;
+          return $error;
+        }
+      }
+    }
+
+    my @del = grep { !exists $new{$_} } keys %old;
+    if ( @del ) {
+      my $err_or_queue = $self->ldap_queue( $new->svcnum, 'attrib_delete',
+        $table, $new->username, @del );
+      unless ( ref($err_or_queue) ) {
+        $dbh->rollback if $oldAutoCommit;
+        return $err_or_queue;
+      }
+      if ( $jobnum ) {
+        my $error = $err_or_queue->depend_insert( $jobnum );
+        if ( $error ) {
+          $dbh->rollback if $oldAutoCommit;
+          return $error;
+        }
+      }
+    }
+  }
+
+  # (sorta) false laziness with FS::svc_acct::replace
+  my @oldgroups = @{$old->usergroup}; #uuuh
+  my @newgroups = $new->radius_groups;
+  my @delgroups = ();
+  foreach my $oldgroup ( @oldgroups ) {
+    if ( grep { $oldgroup eq $_ } @newgroups ) {
+      @newgroups = grep { $oldgroup ne $_ } @newgroups;
+      next;
+    }
+    push @delgroups, $oldgroup;
+  }
+
+  if ( @delgroups ) {
+    my $err_or_queue = $self->ldap_queue( $new->svcnum, 'usergroup_delete',
+      $new->username, @delgroups );
+    unless ( ref($err_or_queue) ) {
+      $dbh->rollback if $oldAutoCommit;
+      return $err_or_queue;
+    }
+    if ( $jobnum ) {
+      my $error = $err_or_queue->depend_insert( $jobnum );
+      if ( $error ) {
+        $dbh->rollback if $oldAutoCommit;
+        return $error;
+      }
+    }
+  }
+
+  if ( @newgroups ) {
+    my $err_or_queue = $self->ldap_queue( $new->svcnum, 'usergroup_insert',
+      $new->username, @newgroups );
+    unless ( ref($err_or_queue) ) {
+      $dbh->rollback if $oldAutoCommit;
+      return $err_or_queue;
+    }
+    if ( $jobnum ) {
+      my $error = $err_or_queue->depend_insert( $jobnum );
+      if ( $error ) {
+        $dbh->rollback if $oldAutoCommit;
+        return $error;
+      }
+    }
+  }
+
+  $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+
+  '';
+}
+
+sub _export_delete {
+  my( $self, $svc_acct ) = (shift, shift);
+  return "ldap delete unimplemented";
+  my $err_or_queue = $self->ldap_queue( $svc_acct->svcnum, 'delete',
+    $svc_acct->username );
+  ref($err_or_queue) ? '' : $err_or_queue;
+}
+
+sub ldap_queue {
+  my( $self, $svcnum, $method ) = (shift, shift, shift);
+  my $queue = new FS::queue {
+    'svcnum' => $svcnum,
+    'job'    => "FS::part_export::ldap::ldap_$method",
+  };
+  $queue->insert(
+    $self->machine,
+    $self->option('dn'),
+    $self->option('password'),
+    @_,
+  ) or $queue;
+}
+
+sub ldap_insert { #subroutine, not method
+  my $dn = ldap_connect(shift, shift, shift);
+  my %attrib = @_;
+
+  my $status = $ldap->add( $dn, attrs => [ %attrib ] );
+  die $status->error if $status->is_error;
+
+  $ldap->unbind;
+}
+
+#sub ldap_delete { #subroutine, not method
+#  my $dbh = ldap_connect(shift, shift, shift);
+#  my $username = shift;
+#
+#  foreach my $table (qw( radcheck radreply usergroup )) {
+#    my $sth = $dbh->prepare( "DELETE FROM $table WHERE UserName = ?" );
+#    $sth->execute($username)
+#      or die "can't delete from $table table: ". $sth->errstr;
+#  }
+#  $dbh->disconnect;
+#}
+
+sub ldap_connect {
+  my( $machine, $dn, $password ) = @_;
+
+  eval "use Net::LDAP";
+  die $@ if $@;
+
+  my $ldap = Net::LDAP->net($machine) or die $@;
+  my $status = $ldap->bind( $dn, password=>$password );
+  die $status->error if $status->is_error;
+
+  $dn;
+}
+
diff --git a/FS/MANIFEST b/FS/MANIFEST
index e37216e19..47c3bf206 100644
--- a/FS/MANIFEST
+++ b/FS/MANIFEST
@@ -75,6 +75,7 @@ FS/part_export/cyrus.pm
 FS/part_export/domain_shellcommands.pm
 FS/part_export/http.pm
 FS/part_export/infostreet.pm
+FS/part_export/ldap.pm
 FS/part_export/null.pm
 FS/part_export/shellcommands.pm
 FS/part_export/shellcommands_withdomain.pm
@@ -149,6 +150,7 @@ t/part_export-cyrus.t
 t/part_export-domain_shellcommands.t
 t/part_export-http.t
 t/part_export-infostreet.t
+t/part_export-ldap.t
 t/part_export-null.t
 t/part_export-shellcommands.t
 t/part_export-shellcommands_withdomain.t
diff --git a/FS/t/part_export-ldap.t b/FS/t/part_export-ldap.t
new file mode 100644
index 000000000..826c3418d
--- /dev/null
+++ b/FS/t/part_export-ldap.t
@@ -0,0 +1,5 @@
+BEGIN { $| = 1; print "1..1\n" }
+END {print "not ok 1\n" unless $loaded;}
+use FS::part_export::ldap;
+$loaded=1;
+print "ok 1\n";