FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $nossh_hack $noexport_hack $conf
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_uppercase
   9              $mydomain
  10              $dirhash
  11              @saltset @pw_set
  12              $rsync $ssh $exportdir $vpopdir);
  13 use Carp;
  14 use File::Path;
  15 use Fcntl qw(:flock);
  16 use FS::UID qw( datasrc );
  17 use FS::Conf;
  18 use FS::Record qw( qsearch qsearchs fields dbh );
  19 use FS::svc_Common;
  20 use Net::SSH;
  21 use FS::part_svc;
  22 use FS::svc_acct_pop;
  23 use FS::svc_acct_sm;
  24 use FS::cust_main_invoice;
  25 use FS::svc_domain;
  26 use FS::raddb;
  27 use FS::queue;
  28 use FS::radius_usergroup;
  29 use FS::Msgcat qw(gettext);
  30
  31 @ISA = qw( FS::svc_Common );
  32
  33 #ask FS::UID to run this stuff for us later
  34 $FS::UID::callback{'FS::svc_acct'} = sub {
  35   $rsync = "rsync";
  36   $ssh = "ssh";
  37   $conf = new FS::Conf;
  38   $dir_prefix = $conf->config('home');
  39   @shells = $conf->config('shells');
  40   $usernamemin = $conf->config('usernamemin') || 2;
  41   $usernamemax = $conf->config('usernamemax');
  42   $passwordmin = $conf->config('passwordmin') || 6;
  43   $passwordmax = $conf->config('passwordmax') || 8;
  44   $username_letter = $conf->exists('username-letter');
  45   $username_letterfirst = $conf->exists('username-letterfirst');
  46   $username_noperiod = $conf->exists('username-noperiod');
  47   $username_uppercase = $conf->exists('username-uppercase');
  48   $username_ampersand = $conf->exists('username-ampersand');
  49   $mydomain = $conf->config('domain');
  50
  51   $dirhash = $conf->config('dirhash') || 0;
  52   $exportdir = "/usr/local/etc/freeside/export." . datasrc;
  53   if ( $conf->exists('vpopmailmachines') ) {
  54     my (@vpopmailmachines) = $conf->config('vpopmailmachines');
  55     my ($machine, $dir, $uid, $gid) = split (/\s+/, $vpopmailmachines[0]);
  56     $vpopdir = $dir;
  57   } else {
  58     $vpopdir = '';
  59   }
  60 };
  61
  62 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  63 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  64
  65 sub _cache {
  66   my $self = shift;
  67   my ( $hashref, $cache ) = @_;
  68   if ( $hashref->{'svc_acct_svcnum'} ) {
  69     $self->{'_domsvc'} = FS::svc_domain->new( {
  70       'svcnum'   => $hashref->{'domsvc'},
  71       'domain'   => $hashref->{'svc_acct_domain'},
  72       'catchall' => $hashref->{'svc_acct_catchall'},
  73     } );
  74   }
  75 }
  76
  77 =head1 NAME
  78
  79 FS::svc_acct - Object methods for svc_acct records
  80
  81 =head1 SYNOPSIS
  82
  83   use FS::svc_acct;
  84
  85   $record = new FS::svc_acct \%hash;
  86   $record = new FS::svc_acct { 'column' => 'value' };
  87
  88   $error = $record->insert;
  89
  90   $error = $new_record->replace($old_record);
  91
  92   $error = $record->delete;
  93
  94   $error = $record->check;
  95
  96   $error = $record->suspend;
  97
  98   $error = $record->unsuspend;
  99
 100   $error = $record->cancel;
 101
 102   %hash = $record->radius;
 103
 104   %hash = $record->radius_reply;
 105
 106   %hash = $record->radius_check;
 107
 108   $domain = $record->domain;
 109
 110   $svc_domain = $record->svc_domain;
 111
 112   $email = $record->email;
 113
 114   $seconds_since = $record->seconds_since($timestamp);
 115
 116 =head1 DESCRIPTION
 117
 118 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 119 FS::svc_Common.  The following fields are currently supported:
 120
 121 =over 4
 122
 123 =item svcnum - primary key (assigned automatcially for new accounts)
 124
 125 =item username
 126
 127 =item _password - generated if blank
 128
 129 =item sec_phrase - security phrase
 130
 131 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 132
 133 =item uid
 134
 135 =item gid
 136
 137 =item finger - GECOS
 138
 139 =item dir - set automatically if blank (and uid is not)
 140
 141 =item shell
 142
 143 =item quota - (unimplementd)
 144
 145 =item slipip - IP address
 146
 147 =item seconds -
 148
 149 =item domsvc - svcnum from svc_domain
 150
 151 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 152
 153 =back
 154
 155 =head1 METHODS
 156
 157 =over 4
 158
 159 =item new HASHREF
 160
 161 Creates a new account.  To add the account to the database, see L<"insert">.
 162
 163 =cut
 164
 165 sub table { 'svc_acct'; }
 166
 167 =item insert
 168
 169 Adds this account to the database.  If there is an error, returns the error,
 170 otherwise returns false.
 171
 172 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 173 defined.  An FS::cust_svc record will be created and inserted.
 174
 175 The additional field I<usergroup> can optionally be defined; if so it should
 176 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 177 sqlradius export only)
 178
 179 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 180 username, uid, and dir fields are defined, the command(s) specified in
 181 the shellmachine-useradd configuration are added to the job queue (see
 182 L<FS::queue> and L<freeside-queued>) to be exectued on shellmachine via ssh.
 183 This behaviour can be surpressed by setting $FS::svc_acct::nossh_hack true.
 184 If the shellmachine-useradd configuration file does not exist,
 185
 186   useradd -d $dir -m -s $shell -u $uid $username
 187
 188 is the default.  If the shellmachine-useradd configuration file exists but
 189 it empty,
 190
 191   cp -pr /etc/skel $dir; chown -R $uid.$gid $dir
 192
 193 is the default instead.  Otherwise the contents of the file are treated as
 194 a double-quoted perl string, with the following variables available:
 195 $username, $uid, $gid, $dir, and $shell.
 196
 197 (TODOC: L<FS::queue> and L<freeside-queued>)
 198
 199 (TODOC: new exports! $noexport_hack)
 200
 201 =cut
 202
 203 sub insert {
 204   my $self = shift;
 205   my $error;
 206
 207   local $SIG{HUP} = 'IGNORE';
 208   local $SIG{INT} = 'IGNORE';
 209   local $SIG{QUIT} = 'IGNORE';
 210   local $SIG{TERM} = 'IGNORE';
 211   local $SIG{TSTP} = 'IGNORE';
 212   local $SIG{PIPE} = 'IGNORE';
 213
 214   my $oldAutoCommit = $FS::UID::AutoCommit;
 215   local $FS::UID::AutoCommit = 0;
 216   my $dbh = dbh;
 217
 218   $error = $self->check;
 219   return $error if $error;
 220
 221   return gettext('username_in_use'). ": ". $self->username
 222     if qsearchs( 'svc_acct', { 'username' => $self->username,
 223                                'domsvc'   => $self->domsvc,
 224                              } );
 225
 226   if ( $self->svcnum ) {
 227     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 228     unless ( $cust_svc ) {
 229       $dbh->rollback if $oldAutoCommit;
 230       return "no cust_svc record found for svcnum ". $self->svcnum;
 231     }
 232     $self->pkgnum($cust_svc->pkgnum);
 233     $self->svcpart($cust_svc->svcpart);
 234   }
 235
 236   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 237   return "Unknown svcpart" unless $part_svc;
 238   return "uid in use"
 239     if $part_svc->part_svc_column('uid')->columnflag ne 'F'
 240       && qsearchs( 'svc_acct', { 'uid' => $self->uid } )
 241       && $self->username !~ /^(hyla)?fax$/
 242     ;
 243
 244   $error = $self->SUPER::insert;
 245   if ( $error ) {
 246     $dbh->rollback if $oldAutoCommit;
 247     return $error;
 248   }
 249
 250   if ( $self->usergroup ) {
 251     foreach my $groupname ( @{$self->usergroup} ) {
 252       my $radius_usergroup = new FS::radius_usergroup ( {
 253         svcnum    => $self->svcnum,
 254         groupname => $groupname,
 255       } );
 256       my $error = $radius_usergroup->insert;
 257       if ( $error ) {
 258         $dbh->rollback if $oldAutoCommit;
 259         return $error;
 260       }
 261     }
 262   }
 263
 264   #new-style exports!
 265   unless ( $noexport_hack ) {
 266     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
 267       my $error = $part_export->export_insert($self);
 268       if ( $error ) {
 269         $dbh->rollback if $oldAutoCommit;
 270         return "exporting to ". $part_export->exporttype.
 271                " (transaction rolled back): $error";
 272       }
 273     }
 274   }
 275
 276   #old-style exports
 277
 278   if ( $vpopdir ) {
 279
 280     my $vpopmail_queue =
 281       new FS::queue {
 282       'svcnum' => $self->svcnum,
 283       'job' => 'FS::svc_acct::vpopmail_insert'
 284     };
 285     $error = $vpopmail_queue->insert( $self->username,
 286       crypt($self->_password,$saltset[int(rand(64))].$saltset[int(rand(64))]),
 287                                       $self->domain,
 288                                       $vpopdir,
 289                                     );
 290     if ( $error ) {
 291       $dbh->rollback if $oldAutoCommit;
 292       return "queueing job (transaction rolled back): $error";
 293     }
 294
 295   }
 296
 297   #end of old-style exports
 298
 299   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 300   ''; #no error
 301 }
 302
 303 sub vpopmail_insert {
 304   my( $username, $password, $domain, $vpopdir ) = @_;
 305
 306   (open(VPASSWD, ">>$exportdir/domains/$domain/vpasswd")
 307     and flock(VPASSWD,LOCK_EX)
 308   ) or die "can't open vpasswd file for $username\@$domain: $exportdir/domains/$domain/vpasswd";
 309   print VPASSWD join(":",
 310     $username,
 311     $password,
 312     '1',
 313     '0',
 314     $username,
 315     "$vpopdir/domains/$domain/$username",
 316     'NOQUOTA',
 317   ), "\n";
 318
 319   flock(VPASSWD,LOCK_UN);
 320   close(VPASSWD);
 321
 322   mkdir "$exportdir/domains/$domain/$username", 0700  or die "can't create Maildir";
 323   mkdir "$exportdir/domains/$domain/$username/Maildir", 0700 or die "can't create Maildir";
 324   mkdir "$exportdir/domains/$domain/$username/Maildir/cur", 0700 or die "can't create Maildir";
 325   mkdir "$exportdir/domains/$domain/$username/Maildir/new", 0700 or die "can't create Maildir";
 326   mkdir "$exportdir/domains/$domain/$username/Maildir/tmp", 0700 or die "can't create Maildir";
 327
 328   my $queue = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_sync' };
 329   my $error = $queue->insert;
 330   die $error if $error;
 331
 332   1;
 333 }
 334
 335 sub vpopmail_sync {
 336
 337   my (@vpopmailmachines) = $conf->config('vpopmailmachines');
 338   my ($machine, $dir, $uid, $gid) = split (/\s+/, $vpopmailmachines[0]);
 339
 340   chdir $exportdir;
 341   my @args = ("$rsync", "-rlpt", "-e", "$ssh", "domains/", "vpopmail\@$machine:$vpopdir/domains/");
 342   system {$args[0]} @args;
 343
 344 }
 345
 346 =item delete
 347
 348 Deletes this account from the database.  If there is an error, returns the
 349 error, otherwise returns false.
 350
 351 The corresponding FS::cust_svc record will be deleted as well.
 352
 353 If the configuration value (see L<FS::Conf>) shellmachine exists, the
 354 command(s) specified in the shellmachine-userdel configuration file are
 355 added to the job queue (see L<FS::queue> and L<freeside-queued>) to be executed
 356 on shellmachine via ssh.  This behavior can be surpressed by setting
 357 $FS::svc_acct::nossh_hack true.  If the shellmachine-userdel configuration
 358 file does not exist,
 359
 360   userdel $username
 361
 362 is the default.  If the shellmachine-userdel configuration file exists but
 363 is empty,
 364
 365   rm -rf $dir
 366
 367 is the default instead.  Otherwise the contents of the file are treated as a
 368 double-quoted perl string, with the following variables available:
 369 $username and $dir.
 370
 371 (TODOC: new exports! $noexport_hack)
 372
 373 =cut
 374
 375 sub delete {
 376   my $self = shift;
 377
 378   if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
 379     return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 380       if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 381   }
 382
 383   return "Can't delete an account which is a (svc_forward) source!"
 384     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 385
 386   return "Can't delete an account which is a (svc_forward) destination!"
 387     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 388
 389   return "Can't delete an account with (svc_www) web service!"
 390     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 391
 392   # what about records in session ? (they should refer to history table)
 393
 394   local $SIG{HUP} = 'IGNORE';
 395   local $SIG{INT} = 'IGNORE';
 396   local $SIG{QUIT} = 'IGNORE';
 397   local $SIG{TERM} = 'IGNORE';
 398   local $SIG{TSTP} = 'IGNORE';
 399   local $SIG{PIPE} = 'IGNORE';
 400
 401   my $oldAutoCommit = $FS::UID::AutoCommit;
 402   local $FS::UID::AutoCommit = 0;
 403   my $dbh = dbh;
 404
 405   foreach my $cust_main_invoice (
 406     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 407   ) {
 408     unless ( defined($cust_main_invoice) ) {
 409       warn "WARNING: something's wrong with qsearch";
 410       next;
 411     }
 412     my %hash = $cust_main_invoice->hash;
 413     $hash{'dest'} = $self->email;
 414     my $new = new FS::cust_main_invoice \%hash;
 415     my $error = $new->replace($cust_main_invoice);
 416     if ( $error ) {
 417       $dbh->rollback if $oldAutoCommit;
 418       return $error;
 419     }
 420   }
 421
 422   foreach my $svc_domain (
 423     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 424   ) {
 425     my %hash = new FS::svc_domain->hash;
 426     $hash{'catchall'} = '';
 427     my $new = new FS::svc_domain \%hash;
 428     my $error = $new->replace($svc_domain);
 429     if ( $error ) {
 430       $dbh->rollback if $oldAutoCommit;
 431       return $error;
 432     }
 433   }
 434
 435   foreach my $radius_usergroup (
 436     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 437   ) {
 438     my $error = $radius_usergroup->delete;
 439     if ( $error ) {
 440       $dbh->rollback if $oldAutoCommit;
 441       return $error;
 442     }
 443   }
 444
 445   my $part_svc = $self->cust_svc->part_svc;
 446
 447   my $error = $self->SUPER::delete;
 448   if ( $error ) {
 449     $dbh->rollback if $oldAutoCommit;
 450     return $error;
 451   }
 452
 453   #new-style exports!
 454   unless ( $noexport_hack ) {
 455     foreach my $part_export ( $part_svc->part_export ) {
 456       my $error = $part_export->export_delete($self);
 457       if ( $error ) {
 458         $dbh->rollback if $oldAutoCommit;
 459         return "exporting to ". $part_export->exporttype.
 460                " (transaction rolled back): $error";
 461       }
 462     }
 463   }
 464
 465   #old-style exports
 466
 467   if ( $vpopdir ) {
 468     my $queue = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_delete' };
 469     $error = $queue->insert( $self->username, $self->domain );
 470     if ( $error ) {
 471       $dbh->rollback if $oldAutoCommit;
 472       return "queueing job (transaction rolled back): $error";
 473     }
 474
 475   }
 476
 477   #end of old-style exports
 478
 479   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 480   '';
 481 }
 482
 483 sub vpopmail_delete {
 484   my( $username, $domain ) = @_;
 485
 486   (open(VPASSWD, "$exportdir/domains/$domain/vpasswd")
 487     and flock(VPASSWD,LOCK_EX)
 488   ) or die "can't open $exportdir/domains/$domain/vpasswd: $!";
 489
 490   open(VPASSWDTMP, ">$exportdir/domains/$domain/vpasswd.tmp")
 491     or die "Can't open $exportdir/domains/$domain/vpasswd.tmp: $!";
 492
 493   while (<VPASSWD>) {
 494     my ($mailbox, $rest) = split(':', $_);
 495     print VPASSWDTMP $_ unless $username eq $mailbox;
 496   }
 497
 498   close(VPASSWDTMP);
 499
 500   rename "$exportdir/domains/$domain/vpasswd.tmp", "$exportdir/domains/$domain/vpasswd"
 501     or die "Can't rename $exportdir/domains/$domain/vpasswd.tmp: $!";
 502
 503   flock(VPASSWD,LOCK_UN);
 504   close(VPASSWD);
 505
 506   rmtree "$exportdir/domains/$domain/$username" or die "can't destroy Maildir";
 507   1;
 508 }
 509
 510 =item replace OLD_RECORD
 511
 512 Replaces OLD_RECORD with this one in the database.  If there is an error,
 513 returns the error, otherwise returns false.
 514
 515 The additional field I<usergroup> can optionally be defined; if so it should
 516 contain an arrayref of group names.  See L<FS::radius_usergroup>.  (used in
 517 sqlradius export only)
 518
 519 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 520 dir field has changed, the command(s) specified in the shellmachine-usermod
 521 configuraiton file are added to the job queue (see L<FS::queue> and
 522 L<freeside-queued>) to be executed on shellmachine via ssh.  This behavior can
 523 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 524 shellmachine-userdel configuration file does not exist or is empty,
 525
 526   [ -d $old_dir ] && mv $old_dir $new_dir || (
 527     chmod u+t $old_dir;
 528     mkdir $new_dir;
 529     cd $old_dir;
 530     find . -depth -print | cpio -pdm $new_dir;
 531     chmod u-t $new_dir;
 532     chown -R $uid.$gid $new_dir;
 533     rm -rf $old_dir
 534   )
 535
 536 is the default.  This behaviour can be surpressed by setting
 537 $FS::svc_acct::nossh_hack true.
 538
 539 =cut
 540
 541 sub replace {
 542   my ( $new, $old ) = ( shift, shift );
 543   my $error;
 544
 545   return "Username in use"
 546     if $old->username ne $new->username &&
 547       qsearchs( 'svc_acct', { 'username' => $new->username,
 548                                'domsvc'   => $new->domsvc,
 549                              } );
 550   {
 551     #no warnings 'numeric';  #alas, a 5.006-ism
 552     local($^W) = 0;
 553     return "Can't change uid!" if $old->uid != $new->uid;
 554   }
 555
 556   #change homdir when we change username
 557   $new->setfield('dir', '') if $old->username ne $new->username;
 558
 559   local $SIG{HUP} = 'IGNORE';
 560   local $SIG{INT} = 'IGNORE';
 561   local $SIG{QUIT} = 'IGNORE';
 562   local $SIG{TERM} = 'IGNORE';
 563   local $SIG{TSTP} = 'IGNORE';
 564   local $SIG{PIPE} = 'IGNORE';
 565
 566   my $oldAutoCommit = $FS::UID::AutoCommit;
 567   local $FS::UID::AutoCommit = 0;
 568   my $dbh = dbh;
 569
 570   $error = $new->SUPER::replace($old);
 571   if ( $error ) {
 572     $dbh->rollback if $oldAutoCommit;
 573     return $error if $error;
 574   }
 575
 576   $old->usergroup( [ $old->radius_groups ] );
 577   if ( $new->usergroup ) {
 578     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 579     my @newgroups = @{$new->usergroup};
 580     foreach my $oldgroup ( @{$old->usergroup} ) {
 581       if ( grep { $oldgroup eq $_ } @newgroups ) {
 582         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 583         next;
 584       }
 585       my $radius_usergroup = qsearchs('radius_usergroup', {
 586         svcnum    => $old->svcnum,
 587         groupname => $oldgroup,
 588       } );
 589       my $error = $radius_usergroup->delete;
 590       if ( $error ) {
 591         $dbh->rollback if $oldAutoCommit;
 592         return "error deleting radius_usergroup $oldgroup: $error";
 593       }
 594     }
 595
 596     foreach my $newgroup ( @newgroups ) {
 597       my $radius_usergroup = new FS::radius_usergroup ( {
 598         svcnum    => $new->svcnum,
 599         groupname => $newgroup,
 600       } );
 601       my $error = $radius_usergroup->insert;
 602       if ( $error ) {
 603         $dbh->rollback if $oldAutoCommit;
 604         return "error adding radius_usergroup $newgroup: $error";
 605       }
 606     }
 607
 608   }
 609
 610   #new-style exports!
 611   unless ( $noexport_hack ) {
 612     foreach my $part_export ( $new->cust_svc->part_svc->part_export ) {
 613       my $error = $part_export->export_replace($new,$old);
 614       if ( $error ) {
 615         $dbh->rollback if $oldAutoCommit;
 616         return "exporting to ". $part_export->exporttype.
 617                " (transaction rolled back): $error";
 618       }
 619     }
 620   }
 621
 622   #old-style exports
 623
 624   if ( $vpopdir ) {
 625     my $cpassword = crypt(
 626       $new->_password,$saltset[int(rand(64))].$saltset[int(rand(64))]
 627     );
 628
 629     if ($old->username ne $new->username || $old->domain ne $new->domain ) {
 630       my $queue  = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_delete' };
 631         $error = $queue->insert( $old->username, $old->domain );
 632       my $queue2 = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_insert' };
 633         $error = $queue2->insert( $new->username,
 634                                   $cpassword,
 635                                   $new->domain,
 636                                   $vpopdir,
 637                                 )
 638         unless $error;
 639     } elsif ($old->_password ne $new->_password) {
 640       my $queue = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_replace_password' };
 641       $error = $queue->insert( $new->username, $cpassword, $new->domain );
 642     }
 643     if ( $error ) {
 644       $dbh->rollback if $oldAutoCommit;
 645       return "queueing job (transaction rolled back): $error";
 646     }
 647   }
 648
 649   #end of old-style exports
 650
 651   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 652   ''; #no error
 653 }
 654
 655 sub vpopmail_replace_password {
 656   my( $username, $password, $domain ) = @_;
 657
 658   (open(VPASSWD, "$exportdir/domains/$domain/vpasswd")
 659     and flock(VPASSWD,LOCK_EX)
 660   ) or die "can't open $exportdir/domains/$domain/vpasswd: $!";
 661
 662   open(VPASSWDTMP, ">$exportdir/domains/$domain/vpasswd.tmp")
 663     or die "Can't open $exportdir/domains/$domain/vpasswd.tmp: $!";
 664
 665   while (<VPASSWD>) {
 666     my ($mailbox, $pw, @rest) = split(':', $_);
 667     print VPASSWDTMP $_ unless $username eq $mailbox;
 668     print VPASSWDTMP join (':', ($mailbox, $password, @rest))
 669       if $username eq $mailbox;
 670   }
 671
 672   close(VPASSWDTMP);
 673
 674   rename "$exportdir/domains/$domain/vpasswd.tmp", "$exportdir/domains/$domain/vpasswd"
 675     or die "Can't rename $exportdir/domains/$domain/vpasswd.tmp: $!";
 676
 677   flock(VPASSWD,LOCK_UN);
 678   close(VPASSWD);
 679
 680   my $queue = new FS::queue { 'job' => 'FS::svc_acct::vpopmail_sync' };
 681   my $error = $queue->insert;
 682   die $error if $error;
 683
 684   1;
 685 }
 686
 687
 688 =item suspend
 689
 690 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 691 error, returns the error, otherwise returns false.
 692
 693 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 694
 695 =cut
 696
 697 sub suspend {
 698   my $self = shift;
 699   my %hash = $self->hash;
 700   unless ( $hash{_password} =~ /^\*SUSPENDED\* /
 701            || $hash{_password} eq '*'
 702          ) {
 703     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 704     my $new = new FS::svc_acct ( \%hash );
 705     $new->replace($self);
 706   } else {
 707     ''; #no error (already suspended)
 708   }
 709 }
 710
 711 =item unsuspend
 712
 713 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 714 an error, returns the error, otherwise returns false.
 715
 716 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 717
 718 =cut
 719
 720 sub unsuspend {
 721   my $self = shift;
 722   my %hash = $self->hash;
 723   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 724     $hash{_password} = $1;
 725     my $new = new FS::svc_acct ( \%hash );
 726     $new->replace($self);
 727   } else {
 728     ''; #no error (already unsuspended)
 729   }
 730 }
 731
 732 =item cancel
 733
 734 Just returns false (no error) for now.
 735
 736 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 737
 738 =item check
 739
 740 Checks all fields to make sure this is a valid service.  If there is an error,
 741 returns the error, otherwise returns false.  Called by the insert and replace
 742 methods.
 743
 744 Sets any fixed values; see L<FS::part_svc>.
 745
 746 =cut
 747
 748 sub check {
 749   my $self = shift;
 750
 751   my($recref) = $self->hashref;
 752
 753   my $x = $self->setfixed;
 754   return $x unless ref($x);
 755   my $part_svc = $x;
 756
 757   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 758     $self->usergroup(
 759       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 760   }
 761
 762   my $error = $self->ut_numbern('svcnum')
 763               || $self->ut_number('domsvc')
 764               || $self->ut_textn('sec_phrase')
 765   ;
 766   return $error if $error;
 767
 768   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 769   if ( $username_uppercase ) {
 770     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
 771       or return gettext('illegal_username'). ": ". $recref->{username};
 772     $recref->{username} = $1;
 773   } else {
 774     $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
 775       or return gettext('illegal_username'). ": ". $recref->{username};
 776     $recref->{username} = $1;
 777   }
 778
 779   if ( $username_letterfirst ) {
 780     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 781   } elsif ( $username_letter ) {
 782     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 783   }
 784   if ( $username_noperiod ) {
 785     $recref->{username} =~ /\./ and return gettext('illegal_username');
 786   }
 787   unless ( $username_ampersand ) {
 788     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 789   }
 790
 791   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 792   $recref->{popnum} = $1;
 793   return "Unknown popnum" unless
 794     ! $recref->{popnum} ||
 795     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 796
 797   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 798
 799     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 800     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 801
 802     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 803     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 804     #not all systems use gid=uid
 805     #you can set a fixed gid in part_svc
 806
 807     return "Only root can have uid 0"
 808       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 809
 810 #    $error = $self->ut_textn('finger');
 811 #    return $error if $error;
 812     $self->getfield('finger') =~
 813       /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/
 814         or return "Illegal finger: ". $self->getfield('finger');
 815     $self->setfield('finger', $1);
 816
 817     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
 818       or return "Illegal directory";
 819     $recref->{dir} = $1;
 820     return "Illegal directory"
 821       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
 822     return "Illegal directory"
 823       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
 824     unless ( $recref->{dir} ) {
 825       $recref->{dir} = $dir_prefix . '/';
 826       if ( $dirhash > 0 ) {
 827         for my $h ( 1 .. $dirhash ) {
 828           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
 829         }
 830       } elsif ( $dirhash < 0 ) {
 831         for my $h ( reverse $dirhash .. -1 ) {
 832           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
 833         }
 834       }
 835       $recref->{dir} .= $recref->{username};
 836     ;
 837     }
 838
 839     unless ( $recref->{username} eq 'sync' ) {
 840       if ( grep $_ eq $recref->{shell}, @shells ) {
 841         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 842       } else {
 843         return "Illegal shell \`". $self->shell. "\'; ".
 844                $conf->dir. "/shells contains: @shells";
 845       }
 846     } else {
 847       $recref->{shell} = '/bin/sync';
 848     }
 849
 850     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 851     $recref->{quota} = $1;
 852
 853   } else {
 854     $recref->{gid} ne '' ?
 855       return "Can't have gid without uid" : ( $recref->{gid}='' );
 856     $recref->{finger} ne '' ?
 857       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 858     $recref->{dir} ne '' ?
 859       return "Can't have directory without uid" : ( $recref->{dir}='' );
 860     $recref->{shell} ne '' ?
 861       return "Can't have shell without uid" : ( $recref->{shell}='' );
 862     $recref->{quota} ne '' ?
 863       return "Can't have quota without uid" : ( $recref->{quota}='' );
 864   }
 865
 866   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
 867     unless ( $recref->{slipip} eq '0e0' ) {
 868       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 869         or return "Illegal slipip". $self->slipip;
 870       $recref->{slipip} = $1;
 871     } else {
 872       $recref->{slipip} = '0e0';
 873     }
 874
 875   }
 876
 877   #arbitrary RADIUS stuff; allow ut_textn for now
 878   foreach ( grep /^radius_/, fields('svc_acct') ) {
 879     $self->ut_textn($_);
 880   }
 881
 882   #generate a password if it is blank
 883   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 884     unless ( $recref->{_password} );
 885
 886   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 887   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
 888     $recref->{_password} = $1.$3;
 889     #uncomment this to encrypt password immediately upon entry, or run
 890     #bin/crypt_pw in cron to give new users a window during which their
 891     #password is available to techs, for faxing, etc.  (also be aware of
 892     #radius issues!)
 893     #$recref->{password} = $1.
 894     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 895     #;
 896   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 897     $recref->{_password} = $1.$3;
 898   } elsif ( $recref->{_password} eq '*' ) {
 899     $recref->{_password} = '*';
 900   } elsif ( $recref->{_password} eq '!!' ) {
 901     $recref->{_password} = '!!';
 902   } else {
 903     #return "Illegal password";
 904     return gettext('illegal_password'). ": ". $recref->{_password};
 905   }
 906
 907   ''; #no error
 908 }
 909
 910 =item radius
 911
 912 Depriciated, use radius_reply instead.
 913
 914 =cut
 915
 916 sub radius {
 917   carp "FS::svc_acct::radius depriciated, use radius_reply";
 918   $_[0]->radius_reply;
 919 }
 920
 921 =item radius_reply
 922
 923 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 924 reply attributes of this record.
 925
 926 Note that this is now the preferred method for reading RADIUS attributes -
 927 accessing the columns directly is discouraged, as the column names are
 928 expected to change in the future.
 929
 930 =cut
 931
 932 sub radius_reply {
 933   my $self = shift;
 934   my %reply =
 935     map {
 936       /^(radius_(.*))$/;
 937       my($column, $attrib) = ($1, $2);
 938       #$attrib =~ s/_/\-/g;
 939       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 940     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 941   if ( $self->ip && $self->ip ne '0e0' ) {
 942     $reply{'Framed-IP-Address'} = $self->ip;
 943   }
 944   %reply;
 945 }
 946
 947 =item radius_check
 948
 949 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 950 check attributes of this record.
 951
 952 Note that this is now the preferred method for reading RADIUS attributes -
 953 accessing the columns directly is discouraged, as the column names are
 954 expected to change in the future.
 955
 956 =cut
 957
 958 sub radius_check {
 959   my $self = shift;
 960   ( 'Password' => $self->_password,
 961     map {
 962       /^(rc_(.*))$/;
 963       my($column, $attrib) = ($1, $2);
 964       #$attrib =~ s/_/\-/g;
 965       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
 966     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
 967   );
 968 }
 969
 970 =item domain
 971
 972 Returns the domain associated with this account.
 973
 974 =cut
 975
 976 sub domain {
 977   my $self = shift;
 978   if ( $self->domsvc ) {
 979     #$self->svc_domain->domain;
 980     my $svc_domain = $self->svc_domain
 981       or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
 982     $svc_domain->domain;
 983   } else {
 984     $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
 985   }
 986 }
 987
 988 =item svc_domain
 989
 990 Returns the FS::svc_domain record for this account's domain (see
 991 L<FS::svc_domain>.
 992
 993 =cut
 994
 995 sub svc_domain {
 996   my $self = shift;
 997   $self->{'_domsvc'}
 998     ? $self->{'_domsvc'}
 999     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1000 }
1001
1002 =item cust_svc
1003
1004 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1005
1006 sub cust_svc {
1007   my $self = shift;
1008   qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1009 }
1010
1011 =item email
1012
1013 Returns an email address associated with the account.
1014
1015 =cut
1016
1017 sub email {
1018   my $self = shift;
1019   $self->username. '@'. $self->domain;
1020 }
1021
1022 =item seconds_since TIMESTAMP
1023
1024 Returns the number of seconds this account has been online since TIMESTAMP.
1025 See L<FS::session>
1026
1027 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1028 L<Time::Local> and L<Date::Parse> for conversion functions.
1029
1030 =cut
1031
1032 #note: POD here, implementation in FS::cust_svc
1033 sub seconds_since {
1034   my $self = shift;
1035   $self->cust_svc->seconds_since(@_);
1036 }
1037
1038 =item radius_groups
1039
1040 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1041
1042 =cut
1043
1044 sub radius_groups {
1045   my $self = shift;
1046   map { $_->groupname }
1047     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1048 }
1049
1050 =back
1051
1052 =head1 SUBROUTINES
1053
1054 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1055
1056 =cut
1057
1058 sub radius_usergroup_selector {
1059   my $sel_groups = shift;
1060   my %sel_groups = map { $_=>1 } @$sel_groups;
1061
1062   my $selectname = shift || 'radius_usergroup';
1063
1064   my $dbh = dbh;
1065   my $sth = $dbh->prepare(
1066     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1067   ) or die $dbh->errstr;
1068   $sth->execute() or die $sth->errstr;
1069   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1070
1071   my $html = <<END;
1072     <SCRIPT>
1073     function ${selectname}_doadd(object) {
1074       var myvalue = object.${selectname}_add.value;
1075       var optionName = new Option(myvalue,myvalue,false,true);
1076       var length = object.$selectname.length;
1077       object.$selectname.options[length] = optionName;
1078       object.${selectname}_add.value = "";
1079     }
1080     </SCRIPT>
1081     <SELECT MULTIPLE NAME="$selectname">
1082 END
1083
1084   foreach my $group ( @all_groups ) {
1085     $html .= '<OPTION';
1086     if ( $sel_groups{$group} ) {
1087       $html .= ' SELECTED';
1088       $sel_groups{$group} = 0;
1089     }
1090     $html .= ">$group</OPTION>\n";
1091   }
1092   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1093     $html .= "<OPTION SELECTED>$group</OPTION>\n";
1094   };
1095   $html .= '</SELECT>';
1096
1097   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1098            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1099
1100   $html;
1101 }
1102
1103 =head1 BUGS
1104
1105 The $recref stuff in sub check should be cleaned up.
1106
1107 The suspend, unsuspend and cancel methods update the database, but not the
1108 current object.  This is probably a bug as it's unexpected and
1109 counterintuitive.
1110
1111 radius_usergroup_selector?  putting web ui components in here?  they should
1112 probably live somewhere else...
1113
1114 =head1 SEE ALSO
1115
1116 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1117 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1118 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1119 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1120 schema.html from the base documentation.
1121
1122 =cut
1123
1124 1;
1125