X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=28ef949860e488c6b73a8e38c8f301bd7b248a3c;hp=9d8566d77c0943b42ee63a60e253183e0d8ccad7;hb=6217d43dfc7345ec7f89be7fb90211fea458efde;hpb=77d3558bd525d7372d2c94213ba8848ed36631aa

diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm
index 9d8566d77..28ef94986 100644
--- a/FS/FS/svc_acct.pm
+++ b/FS/FS/svc_acct.pm
@@ -14,6 +14,7 @@ use vars qw( @ISA $DEBUG $me $conf
              @saltset @pw_set );
 use Carp;
 use Fcntl qw(:flock);
+use Crypt::PasswdMD5;
 use FS::UID qw( datasrc );
 use FS::Conf;
 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
@@ -29,10 +30,13 @@ use FS::radius_usergroup;
 use FS::export_svc;
 use FS::part_export;
 use FS::Msgcat qw(gettext);
+use FS::svc_forward;
+use FS::svc_www;
 
 @ISA = qw( FS::svc_Common );
 
 $DEBUG = 0;
+#$DEBUG = 1;
 $me = '[FS::svc_acct]';
 
 #ask FS::UID to run this stuff for us later
@@ -176,7 +180,7 @@ Creates a new account.  To add the account to the database, see L<"insert">.
 
 sub table { 'svc_acct'; }
 
-=item insert
+=item insert [ , OPTION => VALUE ... ]
 
 Adds this account to the database.  If there is an error, returns the error,
 otherwise returns false.
@@ -185,23 +189,28 @@ The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 defined.  An FS::cust_svc record will be created and inserted.
 
 The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
-sqlradius export only)
+contain an arrayref of group names.  See L<FS::radius_usergroup>.
 
 The additional field I<child_objects> can optionally be defined; if so it
 should contain an arrayref of FS::tablename objects.  They will have their
 svcnum fields set and will be inserted after this record, but before any
 exports are run.
 
+Currently available options are: I<depend_jobnum>
+
+If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
+jobnums), all provisioning jobs will have a dependancy on the supplied
+jobnum(s) (they will not run until the specific job(s) complete(s)).
+
 (TODOC: L<FS::queue> and L<freeside-queued>)
 
 (TODOC: new exports!)
 
-
 =cut
 
 sub insert {
   my $self = shift;
+  my %options = @_;
   my $error;
 
   local $SIG{HUP} = 'IGNORE';
@@ -218,14 +227,6 @@ sub insert {
   $error = $self->check;
   return $error if $error;
 
-  #no, duplicate checking just got a whole lot more complicated
-  #(perhaps keep this check with a config option to turn on?)
-
-  #return gettext('username_in_use'). ": ". $self->username
-  #  if qsearchs( 'svc_acct', { 'username' => $self->username,
-  #                             'domsvc'   => $self->domsvc,
-  #                           } );
-
   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
     unless ( $cust_svc ) {
@@ -236,96 +237,18 @@ sub insert {
     $self->svcpart($cust_svc->svcpart);
   }
 
-  #new duplicate username checking
-
-  my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
-  unless ( $part_svc ) {
+  $error = $self->_check_duplicate;
+  if ( $error ) {
     $dbh->rollback if $oldAutoCommit;
-    return 'unknown svcpart '. $self->svcpart;
-  }
-
-  my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
-  my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
-                                              'domsvc'   => $self->domsvc } );
-  my @dup_uid;
-  if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
-       && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
-    @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
-  } else {
-    @dup_uid = ();
-  }
-
-  if ( @dup_user || @dup_userdomain || @dup_uid ) {
-    my $exports = FS::part_export::export_info('svc_acct');
-    my %conflict_user_svcpart;
-    my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
-
-    foreach my $part_export ( $part_svc->part_export ) {
-
-      #this will catch to the same exact export
-      my @svcparts = map { $_->svcpart }
-        qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
-
-      #this will catch to exports w/same exporthost+type ???
-      #my @other_part_export = qsearch('part_export', {
-      #  'machine'    => $part_export->machine,
-      #  'exporttype' => $part_export->exporttype,
-      #} );
-      #foreach my $other_part_export ( @other_part_export ) {
-      #  push @svcparts, map { $_->svcpart }
-      #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
-      #}
-
-      #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
-      #silly kludge to avoid uninitialized value errors
-      my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
-                     ? $exports->{$part_export->exporttype}{'nodomain'}
-                     : '';
-      if ( $nodomain =~ /^Y/i ) {
-        $conflict_user_svcpart{$_} = $part_export->exportnum
-          foreach @svcparts;
-      } else {
-        $conflict_userdomain_svcpart{$_} = $part_export->exportnum
-          foreach @svcparts;
-      }
-    }
-
-    foreach my $dup_user ( @dup_user ) {
-      my $dup_svcpart = $dup_user->cust_svc->svcpart;
-      if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
-        $dbh->rollback if $oldAutoCommit;
-        return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
-               " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
-      }
-    }
-
-    foreach my $dup_userdomain ( @dup_userdomain ) {
-      my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
-      if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
-        $dbh->rollback if $oldAutoCommit;
-        return "duplicate username\@domain: conflicts with svcnum ".
-               $dup_userdomain->svcnum. " via exportnum ".
-               $conflict_userdomain_svcpart{$dup_svcpart};
-      }
-    }
-
-    foreach my $dup_uid ( @dup_uid ) {
-      my $dup_svcpart = $dup_uid->cust_svc->svcpart;
-      if ( exists($conflict_user_svcpart{$dup_svcpart})
-           || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
-        $dbh->rollback if $oldAutoCommit;
-        return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
-               "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
-                                 || $conflict_userdomain_svcpart{$dup_svcpart};
-      }
-    }
-
+    return $error;
   }
 
-  #see?  i told you it was more complicated
-
   my @jobnums;
-  $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
+  $error = $self->SUPER::insert(
+    'jobnums'       => \@jobnums,
+    'child_objects' => $self->child_objects,
+    %options,
+  );
   if ( $error ) {
     $dbh->rollback if $oldAutoCommit;
     return $error;
@@ -395,6 +318,22 @@ sub insert {
           return "error queuing welcome email: $error";
         }
 
+        if ( $options{'depend_jobnum'} ) {
+          warn "$me depend_jobnum found; adding to welcome email dependancies"
+            if $DEBUG;
+          if ( ref($options{'depend_jobnum'}) ) {
+            warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
+                 "to welcome email dependancies"
+              if $DEBUG;
+            push @jobnums, @{ $options{'depend_jobnum'} };
+          } else {
+            warn "$me adding job $options{'depend_jobnum'} ".
+                 "to welcome email dependancies"
+              if $DEBUG;
+            push @jobnums, $options{'depend_jobnum'};
+          }
+        }
+
         foreach my $jobnum ( @jobnums ) {
           my $error = $wqueue->depend_insert($jobnum);
           if ( $error ) {
@@ -436,7 +375,7 @@ sub delete {
     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 
   return "Can't delete an account with (svc_www) web service!"
-    if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
+    if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 
   # what about records in session ? (they should refer to history table)
 
@@ -507,8 +446,8 @@ Replaces OLD_RECORD with this one in the database.  If there is an error,
 returns the error, otherwise returns false.
 
 The additional field I<usergroup> can optionally be defined; if so it should
-contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
-sqlradius export only)
+contain an arrayref of group names.  See L<FS::radius_usergroup>.
+
 
 =cut
 
@@ -584,6 +523,15 @@ sub replace {
 
   }
 
+  if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
+    $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
+    $error = $new->_check_duplicate;
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return $error;
+    }
+  }
+
   $error = $new->SUPER::replace($old);
   if ( $error ) {
     $dbh->rollback if $oldAutoCommit;
@@ -646,10 +594,36 @@ sub unsuspend {
 
 =item cancel
 
-Just returns false (no error) for now.
-
 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 
+If the B<auto_unset_catchall> configuration option is set, this method will
+automatically remove any references to the canceled service in the catchall
+field of svc_domain.  This allows packages that contain both a svc_domain and
+its catchall svc_acct to be canceled in one step.
+
+=cut
+
+sub cancel {
+  # Only one thing to do at this level
+  my $self = shift;
+  foreach my $svc_domain (
+      qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
+    if($conf->exists('auto_unset_catchall')) {
+      my %hash = $svc_domain->hash;
+      $hash{catchall} = '';
+      my $new = new FS::svc_domain ( \%hash );
+      my $error = $new->replace($svc_domain);
+      return $error if $error;
+    } else {
+      return "cannot unprovision svc_acct #".$self->svcnum.
+	  " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
+    }
+  }
+
+  $self->SUPER::cancel;
+}
+
+
 =item check
 
 Checks all fields to make sure this is a valid service.  If there is an error,
@@ -776,6 +750,15 @@ sub check {
 
   #  $error = $self->ut_textn('finger');
   #  return $error if $error;
+  if ( $self->getfield('finger') eq '' ) {
+    my $cust_pkg = $self->svcnum
+      ? $self->cust_svc->cust_pkg
+      : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
+    if ( $cust_pkg ) {
+      my $cust_main = $cust_pkg->cust_main;
+      $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
+    }
+  }
   $self->getfield('finger') =~
     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
       or return "Illegal finger: ". $self->getfield('finger');
@@ -836,6 +819,10 @@ sub check {
 
 =item _check_system
 
+Internal function to check the username against the list of system usernames
+from the I<system_usernames> configuration value.  Returns true if the username
+is listed on the system username list.
+
 =cut
 
 sub _check_system {
@@ -845,6 +832,124 @@ sub _check_system {
         );
 }
 
+=item _check_duplicate
+
+Internal function to check for duplicates usernames, username@domain pairs and
+uids.
+
+If the I<global_unique-username> configuration value is set to B<username> or
+B<username@domain>, enforces global username or username@domain uniqueness.
+
+In all cases, check for duplicate uids and usernames or username@domain pairs
+per export and with identical I<svcpart> values.
+
+=cut
+
+sub _check_duplicate {
+  my $self = shift;
+
+  #this is Pg-specific.  what to do for mysql etc?
+  # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
+  warn "$me locking svc_acct table for duplicate search" if $DEBUG;
+  dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
+    or die dbh->errstr;
+  warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
+
+  my $svcpart = $self->svcpart;
+  my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
+  unless ( $part_svc ) {
+    return 'unknown svcpart '. $self->svcpart;
+  }
+
+  my $global_unique = $conf->config('global_unique-username');
+
+  my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+                 qsearch( 'svc_acct', { 'username' => $self->username } );
+  return gettext('username_in_use')
+    if $global_unique eq 'username' && @dup_user;
+
+  my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+                       qsearch( 'svc_acct', { 'username' => $self->username,
+                                              'domsvc'   => $self->domsvc } );
+  return gettext('username_in_use')
+    if $global_unique eq 'username@domain' && @dup_userdomain;
+
+  my @dup_uid;
+  if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
+       && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
+    @dup_uid = grep { $svcpart != $_->svcpart }
+               qsearch( 'svc_acct', { 'uid' => $self->uid } );
+  } else {
+    @dup_uid = ();
+  }
+
+  if ( @dup_user || @dup_userdomain || @dup_uid ) {
+    my $exports = FS::part_export::export_info('svc_acct');
+    my %conflict_user_svcpart;
+    my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
+
+    foreach my $part_export ( $part_svc->part_export ) {
+
+      #this will catch to the same exact export
+      my @svcparts = map { $_->svcpart } $part_export->export_svc;
+
+      #this will catch to exports w/same exporthost+type ???
+      #my @other_part_export = qsearch('part_export', {
+      #  'machine'    => $part_export->machine,
+      #  'exporttype' => $part_export->exporttype,
+      #} );
+      #foreach my $other_part_export ( @other_part_export ) {
+      #  push @svcparts, map { $_->svcpart }
+      #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
+      #}
+
+      #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
+      #silly kludge to avoid uninitialized value errors
+      my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
+                     ? $exports->{$part_export->exporttype}{'nodomain'}
+                     : '';
+      if ( $nodomain =~ /^Y/i ) {
+        $conflict_user_svcpart{$_} = $part_export->exportnum
+          foreach @svcparts;
+      } else {
+        $conflict_userdomain_svcpart{$_} = $part_export->exportnum
+          foreach @svcparts;
+      }
+    }
+
+    foreach my $dup_user ( @dup_user ) {
+      my $dup_svcpart = $dup_user->cust_svc->svcpart;
+      if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
+        return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
+               " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
+      }
+    }
+
+    foreach my $dup_userdomain ( @dup_userdomain ) {
+      my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
+      if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+        return "duplicate username\@domain: conflicts with svcnum ".
+               $dup_userdomain->svcnum. " via exportnum ".
+               $conflict_userdomain_svcpart{$dup_svcpart};
+      }
+    }
+
+    foreach my $dup_uid ( @dup_uid ) {
+      my $dup_svcpart = $dup_uid->cust_svc->svcpart;
+      if ( exists($conflict_user_svcpart{$dup_svcpart})
+           || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+        return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
+               "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
+                                 || $conflict_userdomain_svcpart{$dup_svcpart};
+      }
+    }
+
+  }
+
+  return '';
+
+}
+
 =item radius
 
 Depriciated, use radius_reply instead.
@@ -1061,6 +1166,104 @@ sub radius_groups {
   }
 }
 
+=item clone_suspended
+
+Constructor used by FS::part_export::_export_suspend fallback.  Document
+better.
+
+=cut
+
+sub clone_suspended {
+  my $self = shift;
+  my %hash = $self->hash;
+  $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
+  new FS::svc_acct \%hash;
+}
+
+=item clone_kludge_unsuspend 
+
+Constructor used by FS::part_export::_export_unsuspend fallback.  Document
+better.
+
+=cut
+
+sub clone_kludge_unsuspend {
+  my $self = shift;
+  my %hash = $self->hash;
+  $hash{_password} = '';
+  new FS::svc_acct \%hash;
+}
+
+=item check_password 
+
+Checks the supplied password against the (possibly encrypted) password in the
+database.  Returns true for a sucessful authentication, false for no match.
+
+Currently supported encryptions are: classic DES crypt() and MD5
+
+=cut
+
+sub check_password {
+  my($self, $check_password) = @_;
+
+  #remove old-style SUSPENDED kludge, they should be allowed to login to
+  #self-service and pay up
+  ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
+
+  #eventually should check a "password-encoding" field
+  if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
+    return 0;
+  } elsif ( length($password) < 13 ) { #plaintext
+    $check_password eq $password;
+  } elsif ( length($password) == 13 ) { #traditional DES crypt
+    crypt($check_password, $password) eq $password;
+  } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
+    unix_md5_crypt($check_password, $password) eq $password;
+  } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
+    warn "Can't check password: Blowfish encryption not yet supported, svcnum".
+         $self->svcnum. "\n";
+    0;
+  } else {
+    warn "Can't check password: Unrecognized encryption for svcnum ".
+         $self->svcnum. "\n";
+    0;
+  }
+
+}
+
+=item crypt_password
+
+Returns an encrypted password, either by passing through an encrypted password
+in the database or by encrypting a plaintext password from the database.
+
+=cut
+
+sub crypt_password {
+  my $self = shift;
+  #false laziness w/shellcommands.pm
+  #eventually should check a "password-encoding" field
+  if ( length($self->_password) == 13
+       || $self->_password =~ /^\$(1|2a?)\$/ ) {
+    $self->_password;
+  } else {
+    crypt(
+      $self->_password,
+      $saltset[int(rand(64))].$saltset[int(rand(64))]
+    );
+  }
+}
+
+=item virtual_maildir
+
+Returns $domain/maildirs/$username/
+
+=cut
+
+sub virtual_maildir {
+  my $self = shift;
+  $self->domain. '/maildirs/'. $self->username. '/';
+}
+
 =back
 
 =head1 SUBROUTINES
@@ -1236,6 +1439,9 @@ counterintuitive.
 radius_usergroup_selector?  putting web ui components in here?  they should
 probably live somewhere else...
 
+insertion of RADIUS group stuff in insert could be done with child_objects now
+(would probably clean up export of them too)
+
 =head1 SEE ALSO
 
 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,