X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fsvc_acct.pm;h=d806fe9bc1c6759235946519fb306affbf244ec1;hb=f441bdef352ddd432e305da35e80813ca30e517f;hp=f66c715cd6ba17a8241091b848dea9d15b44b0a2;hpb=c4ed19db84cc71ef13ded9f86ba413411b5c05f6;p=freeside.git

diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm
index f66c715cd..d806fe9bc 100644
--- a/FS/FS/svc_acct.pm
+++ b/FS/FS/svc_acct.pm
@@ -1,12 +1,13 @@
 package FS::svc_acct;
 
 use strict;
-use vars qw( @ISA $DEBUG $me $conf
+use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
              $dir_prefix @shells $usernamemin
              $usernamemax $passwordmin $passwordmax
              $username_ampersand $username_letter $username_letterfirst
              $username_noperiod $username_nounderscore $username_nodash
              $username_uppercase
+             $password_noampersand $password_noexclamation
              $welcome_template $welcome_from $welcome_subject $welcome_mimetype
              $smtpmachine
              $radius_password $radius_ip
@@ -14,7 +15,7 @@ use vars qw( @ISA $DEBUG $me $conf
              @saltset @pw_set );
 use Carp;
 use Fcntl qw(:flock);
-use Crypt::PasswdMD5;
+use Crypt::PasswdMD5 1.2;
 use FS::UID qw( datasrc );
 use FS::Conf;
 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
@@ -55,6 +56,8 @@ $FS::UID::callback{'FS::svc_acct'} = sub {
   $username_nodash = $conf->exists('username-nodash');
   $username_uppercase = $conf->exists('username-uppercase');
   $username_ampersand = $conf->exists('username-ampersand');
+  $password_noampersand = $conf->exists('password-noexclamation');
+  $password_noexclamation = $conf->exists('password-noexclamation');
   $dirhash = $conf->config('dirhash') || 0;
   if ( $conf->exists('welcome_email') ) {
     $welcome_template = new Text::Template (
@@ -164,7 +167,9 @@ FS::svc_Common.  The following fields are currently supported:
 
 =item domsvc - svcnum from svc_domain
 
-=item radius_I<Radius_Attribute> - I<Radius-Attribute>
+=item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
+
+=item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 
 =back
 
@@ -194,7 +199,10 @@ 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.
+exports are run.  Each element of the array can also optionally be a
+two-element array reference containing the child object and the name of an
+alternate field to be filled in with the newly-inserted svcnum, for example
+C<[ $svc_forward, 'srcsvc' ]>
 
 Currently available options are: I<depend_jobnum>
 
@@ -227,14 +235,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 ) {
@@ -245,94 +245,12 @@ 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'       => \@jobnums,
@@ -358,15 +276,12 @@ sub insert {
     }
   }
 
-  #false laziness with sub replace (and cust_main)
-  my $queue = new FS::queue {
-    'svcnum' => $self->svcnum,
-    'job'    => 'FS::svc_acct::append_fuzzyfiles'
-  };
-  $error = $queue->insert($self->username);
-  if ( $error ) {
-    $dbh->rollback if $oldAutoCommit;
-    return "queueing job (transaction rolled back): $error";
+  unless ( $skip_fuzzyfiles ) {
+    $error = $self->queue_fuzzyfiles_update;
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return "updating fuzzy search cache: $error";
+    }
   }
 
   my $cust_pkg = $self->cust_svc->cust_pkg;
@@ -383,7 +298,7 @@ sub insert {
     #welcome email
     my $to = '';
     if ( $welcome_template && $cust_pkg ) {
-      my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
+      my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
       if ( $to ) {
         my $wqueue = new FS::queue {
           'svcnum' => $self->svcnum,
@@ -613,22 +528,26 @@ 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;
     return $error if $error;
   }
 
-  if ( $new->username ne $old->username ) {
-    #false laziness with sub insert (and cust_main)
-    my $queue = new FS::queue {
-      'svcnum' => $new->svcnum,
-      'job'    => 'FS::svc_acct::append_fuzzyfiles'
-    };
-    $error = $queue->insert($new->username);
+  if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
+    $error = $new->queue_fuzzyfiles_update;
     if ( $error ) {
       $dbh->rollback if $oldAutoCommit;
-      return "queueing job (transaction rolled back): $error";
+      return "updating fuzzy search cache: $error";
     }
   }
 
@@ -636,6 +555,42 @@ sub replace {
   ''; #no error
 }
 
+=item queue_fuzzyfiles_update
+
+Used by insert & replace to update the fuzzy search cache
+
+=cut
+
+sub queue_fuzzyfiles_update {
+  my $self = 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';
+
+  my $oldAutoCommit = $FS::UID::AutoCommit;
+  local $FS::UID::AutoCommit = 0;
+  my $dbh = dbh;
+
+  my $queue = new FS::queue {
+    'svcnum' => $self->svcnum,
+    'job'    => 'FS::svc_acct::append_fuzzyfiles'
+  };
+  my $error = $queue->insert($self->username);
+  if ( $error ) {
+    $dbh->rollback if $oldAutoCommit;
+    return "queueing job (transaction rolled back): $error";
+  }
+
+  $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+  '';
+
+}
+
+
 =item suspend
 
 Suspends this account by calling export-specific suspend hooks.  If there is
@@ -764,6 +719,12 @@ sub check {
   unless ( $username_ampersand ) {
     $recref->{username} =~ /\&/ and return gettext('illegal_username');
   }
+  if ( $password_noampersand ) {
+    $recref->{_password} =~ /\&/ and return gettext('illegal_password');
+  }
+  if ( $password_noexclamation ) {
+    $recref->{_password} =~ /\!/ and return gettext('illegal_password');
+  }
 
   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
   $recref->{popnum} = $1;
@@ -783,9 +744,7 @@ sub check {
 
     return "Only root can have uid 0"
       if $recref->{uid} == 0
-         && $recref->{username} ne 'root'
-         && $recref->{username} ne 'toor';
-
+         && $recref->{username} !~ /^(root|toor|smtp)$/;
 
     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
       or return "Illegal directory: ". $recref->{dir};
@@ -900,6 +859,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 {
@@ -909,6 +872,123 @@ 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 $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
+  unless ( $part_svc ) {
+    return 'unknown svcpart '. $self->svcpart;
+  }
+
+  my $global_unique = $conf->config('global_unique-username') || 'none';
+
+  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 { !$self->svcnum || $_->svcnum != $self->svcnum }
+               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.
@@ -943,6 +1023,9 @@ sub radius_reply {
   if ( $self->slipip && $self->slipip ne '0e0' ) {
     $reply{$radius_ip} = $self->slipip;
   }
+  if ( $self->seconds !~ /^$/ ) {
+    $reply{'Session-Timeout'} = $self->seconds;
+  }
   %reply;
 }
 
@@ -980,7 +1063,7 @@ Returns the domain associated with this account.
 sub domain {
   my $self = shift;
   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
-  my $svc_domain = $self->svc_domain
+  my $svc_domain = $self->svc_domain(@_)
     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
   $svc_domain->domain;
 }
@@ -1018,7 +1101,7 @@ Returns an email address associated with the account.
 
 sub email {
   my $self = shift;
-  $self->username. '@'. $self->domain;
+  $self->username. '@'. $self->domain(@_);
 }
 
 =item acct_snarf
@@ -1095,16 +1178,16 @@ sub attribute_since_sqlradacct {
   $self->cust_svc->attribute_since_sqlradacct(@_);
 }
 
-=item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
+=item get_session_history TIMESTAMP_START TIMESTAMP_END
 
 Returns an array of hash references of this customers login history for the
 given time range.  (document this better)
 
 =cut
 
-sub get_session_history_sqlradacct {
+sub get_session_history {
   my $self = shift;
-  $self->cust_svc->get_session_history_sqlradacct(@_);
+  $self->cust_svc->get_session_history(@_);
 }
 
 =item radius_groups
@@ -1190,11 +1273,18 @@ sub check_password {
 
 }
 
-=item crypt_password
+=item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
 
 Returns an encrypted password, either by passing through an encrypted password
 in the database or by encrypting a plaintext password from the database.
 
+The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
+UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
+distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
+OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
+encryption type is only used if the password is not already encrypted in the
+database.
+
 =cut
 
 sub crypt_password {
@@ -1205,10 +1295,19 @@ sub crypt_password {
        || $self->_password =~ /^\$(1|2a?)\$/ ) {
     $self->_password;
   } else {
-    crypt(
-      $self->_password,
-      $saltset[int(rand(64))].$saltset[int(rand(64))]
-    );
+    my $encryption = scalar(@_) ? shift : 'crypt';
+    if ( $encryption eq 'crypt' ) {
+      crypt(
+        $self->_password,
+        $saltset[int(rand(64))].$saltset[int(rand(64))]
+      );
+    } elsif ( $encryption eq 'md5' ) {
+      unix_md5_crypt( $self->_password );
+    } elsif ( $encryption eq 'blowfish' ) {
+      die "unknown encryption method $encryption";
+    } else {
+      die "unknown encryption method $encryption";
+    }
   }
 }
 
@@ -1367,7 +1466,7 @@ sub radius_usergroup_selector {
 END
 
   foreach my $group ( @all_groups ) {
-    $html .= '<OPTION';
+    $html .= qq(<OPTION VALUE="$group");
     if ( $sel_groups{$group} ) {
       $html .= ' SELECTED';
       $sel_groups{$group} = 0;
@@ -1375,7 +1474,7 @@ END
     $html .= ">$group</OPTION>\n";
   }
   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
-    $html .= "<OPTION SELECTED>$group</OPTION>\n";
+    $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
   };
   $html .= '</SELECT>';