FS/FS/part_export/ldap.pm

   1 package FS::part_export::ldap;
   2
   3 use vars qw(@ISA %info @saltset);
   4 use Tie::IxHash;
   5 use FS::Record qw( dbh );
   6 use FS::part_export;
   7
   8 @ISA = qw(FS::part_export);
   9
  10 tie my %options, 'Tie::IxHash',
  11   'dn'         => { label=>'Root DN' },
  12   'password'   => { label=>'Root DN password' },
  13   'userdn'     => { label=>'User DN' },
  14   'key_attrib' => { label=>'Key attribute name',
  15                     default=>'uid' },
  16   'attributes' => { label=>'Attributes',
  17                     type=>'textarea',
  18                     default=>join("\n",
  19                       'uid $username',
  20                       'mail $username\@$domain',
  21                       'uidno $uid',
  22                       'gidno $gid',
  23                       'cn $first',
  24                       'sn $last',
  25                       'mailquota $quota',
  26                       'vmail',
  27                       'location',
  28                       'mailtag',
  29                       'mailhost',
  30                       'mailmessagestore $dir',
  31                       'userpassword $crypt_password',
  32                       'hint',
  33                       'answer $sec_phrase',
  34                       'objectclass top,person,inetOrgPerson',
  35                     ),
  36                   },
  37   'radius'     => { label=>'Export RADIUS attributes', type=>'checkbox', },
  38 ;
  39
  40 %info = (
  41   'svc'     => 'svc_acct',
  42   'desc'    => 'Real-time export to LDAP',
  43   'options' => \%options,
  44   'default_svc_class' => 'Email',
  45   'notes'   => <<'END'
  46 Real-time export to arbitrary LDAP attributes.  Requires installation of
  47 <a href="http://search.cpan.org/dist/Net-LDAP">Net::LDAP</a> from CPAN.
  48 END
  49 );
  50
  51 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  52
  53 sub rebless { shift; }
  54
  55 sub svc_context_eval {
  56   # This should possibly be in svc_Common?
  57   # Except the only places we use it are here and in shellcommands,
  58   # and it's not even the same version.
  59   my $svc_acct = shift;
  60   no strict 'refs';
  61   ${$_} = $svc_acct->getfield($_) foreach $svc_acct->fields;
  62   ${$_} = $svc_acct->$_() foreach qw( domain ldap_password );
  63   my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
  64   if ( $cust_pkg ) {
  65     my $cust_main = $cust_pkg->cust_main;
  66     ${$_} = $cust_main->getfield($_) foreach qw(first last);
  67   }
  68   # DEPRECATED, probably fails for non-plain password encoding
  69   $crypt_password = ''; #surpress "used only once" warnings
  70   $crypt_password = '{crypt}'. crypt( $svc_acct->_password,
  71                              $saltset[int(rand(64))].$saltset[int(rand(64))] );
  72
  73   return map { eval(qq("$_")) } @_ ;
  74 }
  75
  76 sub key_attrib {
  77   my $self = shift;
  78   return $self->option('key_attrib') if $self->option('key_attrib');
  79   # otherwise, guess that it's the one that's set to $username
  80   foreach ( split("\n",$self->option('attributes')) ) {
  81     /^\s*(\w+)\s+\$username\s*$/ && return $1;
  82   }
  83   # can't recover from that, but we can fail in a more obvious way
  84   # than the old code did...
  85   die "no key_attrib set in LDAP export\n";
  86 }
  87
  88 sub ldap_attrib {
  89   # Convert the svc_acct to its LDAP attribute set.
  90   my($self, $svc_acct) = (shift, shift);
  91   my %attrib = map    { /^\s*(\w+)\s+(.*\S)\s*$/;
  92                         ( $1 => $2 ); }
  93                  grep { /^\s*(\w+)\s+(.*\S)\s*$/ }
  94                    split("\n", $self->option('attributes'));
  95
  96   my @vals = svc_context_eval($svc_acct, values(%attrib));
  97   @attrib{keys(%attrib)} = @vals;
  98
  99   if ( $self->option('radius') ) {
 100     foreach my $table (qw(reply check)) {
 101       my $method = "radius_$table";
 102       my %radius = $svc_acct->$method();
 103       foreach my $radius ( keys %radius ) {
 104         ( my $ldap = $radius ) =~ s/\-//g;
 105         $attrib{$ldap} = $radius{$radius};
 106       }
 107     }
 108   }
 109   return %attrib;
 110 }
 111
 112 sub _export_insert {
 113   my($self, $svc_acct) = (shift, shift);
 114
 115   my $err_or_queue = $self->ldap_queue(
 116     $svc_acct->svcnum,
 117     'insert',
 118     $self->key_attrib,
 119     $self->ldap_attrib($svc_acct),
 120   );
 121   return $err_or_queue unless ref($err_or_queue);
 122
 123   '';
 124 }
 125
 126 sub _export_replace {
 127   my( $self, $new, $old ) = (shift, shift, shift);
 128
 129   local $SIG{HUP} = 'IGNORE';
 130   local $SIG{INT} = 'IGNORE';
 131   local $SIG{QUIT} = 'IGNORE';
 132   local $SIG{TERM} = 'IGNORE';
 133   local $SIG{TSTP} = 'IGNORE';
 134   local $SIG{PIPE} = 'IGNORE';
 135
 136   my $oldAutoCommit = $FS::UID::AutoCommit;
 137   local $FS::UID::AutoCommit = 0;
 138   my $dbh = dbh;
 139
 140   my $jobnum = '';
 141
 142   # the Lazy way: nuke the entry and recreate it.
 143   # any reason this shouldn't work?  Freeside _has_ to have
 144   # write access to these entries and their parent DN.
 145   my $key = $self->key_attrib;
 146   my %attrib = $self->ldap_attrib($old);
 147   my $err_or_queue = $self->ldap_queue(
 148     $old->svcnum,
 149     'delete',
 150     $key,
 151     $attrib{$key}
 152   );
 153   if( !ref($err_or_queue) ) {
 154     $dbh->rollback if $oldAutoCommit;
 155     return $err_or_queue;
 156   }
 157   $jobnum = $err_or_queue->jobnum;
 158   $err_or_queue = $self->ldap_queue(
 159     $new->svcnum,
 160     'insert',
 161     $key,
 162     $self->ldap_attrib($new)
 163   );
 164   if( !ref($err_or_queue) ) {
 165     $dbh->rollback if $oldAutoCommit;
 166     return $err_or_queue;
 167   }
 168   $err_or_queue = $err_or_queue->depend_insert($jobnum);
 169   if( $err_or_queue ) {
 170     $dbh->rollback if $oldAutoCommit;
 171     return $err_or_queue;
 172   }
 173
 174   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 175
 176   '';
 177 }
 178
 179 sub _export_delete {
 180   my( $self, $svc_acct ) = (shift, shift);
 181
 182   my $key = $self->key_attrib;
 183   my ( $val ) = map { /^\s*$key\s+(.*\S)\s*$/ ? $1 : () }
 184                     split("\n", $self->option('attributes'));
 185   ( $val ) = svc_context_eval($svc_acct, $val);
 186   my $err_or_queue = $self->ldap_queue( $svc_acct->svcnum, 'delete',
 187     $key, $val );
 188   ref($err_or_queue) ? '' : $err_or_queue;
 189 }
 190
 191 sub ldap_queue {
 192   my( $self, $svcnum, $method ) = (shift, shift, shift);
 193   my $queue = new FS::queue {
 194     'svcnum' => $svcnum,
 195     'job'    => "FS::part_export::ldap::ldap_$method",
 196   };
 197   $queue->insert(
 198     $self->machine,
 199     $self->option('dn'),
 200     $self->option('password'),
 201     $self->option('userdn'),
 202     @_,
 203   ) or $queue;
 204 }
 205
 206 sub ldap_insert { #subroutine, not method
 207   my $ldap = ldap_connect(shift, shift, shift);
 208   my( $userdn, $key_attrib, %attrib ) = @_;
 209
 210   $userdn = "$key_attrib=$attrib{$key_attrib}, $userdn";
 211   #icky hack, but should be unsurprising to the LDAPers
 212   foreach my $key ( grep { $attrib{$_} =~ /,/ } keys %attrib ) {
 213     $attrib{$key} = [ split(/,/, $attrib{$key}) ];
 214   }
 215
 216   my $status = $ldap->add( $userdn, attrs => [ %attrib ] );
 217   die 'LDAP error: '. $status->error. "\n" if $status->is_error;
 218
 219   $ldap->unbind;
 220 }
 221
 222 sub ldap_delete {
 223   my $ldap = ldap_connect(shift, shift, shift);
 224
 225   my $entry = ldap_fetch($ldap, @_);
 226   if($entry) {
 227     my $status = $ldap->delete($entry);
 228     die 'LDAP error: '.$status->error."\n" if $status->is_error;
 229   }
 230   $ldap->unbind;
 231   # should failing to find the entry be fatal?
 232   # if it is, it will block unprovisioning the service, which is a pain.
 233 }
 234
 235 sub ldap_fetch {
 236   # avoid needless duplication in delete and modify
 237   my( $ldap, $userdn, %key_data ) = @_;
 238   my $filter = join('', map { "($_=$key_data{$_})" } keys(%key_data));
 239
 240   my $status = $ldap->search( base => $userdn,
 241                               scope => 'one',
 242                               filter => $filter );
 243   die 'LDAP error: '.$status->error."\n" if $status->is_error;
 244   my ($entry) = $status->entries;
 245   warn "Entry '$filter' not found in LDAP\n" if !$entry;
 246   return $entry;
 247 }
 248
 249 sub ldap_connect {
 250   my( $machine, $dn, $password ) = @_;
 251   my %bind_options;
 252   $bind_options{password} = $password if length($password);
 253
 254   eval "use Net::LDAP";
 255   die $@ if $@;
 256
 257   my $ldap = Net::LDAP->new($machine) or die $@;
 258   my $status = $ldap->bind( $dn, %bind_options );
 259   die 'LDAP error: '. $status->error. "\n" if $status->is_error;
 260
 261   $ldap;
 262 }
 263
 264 1;
 265