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